diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,99 +1,416 @@ -Name: Cabal -Version: 1.4.0.2 -Copyright: 2003-2006, Isaac Jones - 2005-2008, Duncan Coutts -License: BSD3 -License-File: LICENSE -Author: Isaac Jones - Duncan Coutts -Maintainer: cabal-devel@haskell.org -Homepage: http://www.haskell.org/cabal/ -Synopsis: A framework for packaging Haskell software -Description: - The Haskell Common Architecture for Building Applications and - Libraries: a framework defining a common interface for authors to more - easily build their Haskell applications in a portable way. - . - The Haskell Cabal is meant to be a part of a larger infrastructure - for distributing, organizing, and cataloging Haskell libraries - and tools. -Category: Distribution -Build-Type: Custom --- Even though we do use the default Setup.lhs it's vital to bootstrapping --- that we build Setup.lhs using our own local Cabal source code. +cabal-version: 3.6 +name: Cabal +version: 3.16.1.0 +copyright: 2003-2025, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: A framework for packaging Haskell software +description: + The Haskell Common Architecture for Building Applications and + Libraries: a framework defining a common interface for authors to more + easily build their Haskell applications in a portable way. + . + The Haskell Cabal is part of a larger infrastructure for distributing, + organizing, and cataloging Haskell libraries and tools. +category: Distribution +build-type: Simple +-- If we use a new Cabal feature, this needs to be changed to Custom so +-- we can bootstrap. -Extra-Source-Files: - README changelog - Distribution/Simple/GHC/mkGHCMakefile.sh - Distribution/Simple/GHC/Makefile.in +extra-doc-files: + README.md ChangeLog.md -Flag small_base - Description: Choose the new smaller, split-up base package. +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal -Library - if flag(small_base) - Build-Depends: base >= 3 && < 4, - directory >= 1 && < 1.1, - process >= 1 && < 1.1, - old-time >= 1 && < 1.1, - containers >= 0.1 && < 0.2, - array >= 0.1 && < 0.2, - pretty >= 1 && < 1.1 +flag git-rev + description: include Git revision hash in version + default: False + manual: True + +library + default-language: Haskell2010 + hs-source-dirs: src + + build-depends: + , Cabal-syntax ^>= 3.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.15 else - Build-Depends: base < 3 - Build-Depends: filepath >= 1 && < 1.2 + build-depends: + , unix >= 2.8.6.0 && < 2.9 - GHC-Options: -Wall - CPP-Options: "-DCABAL_VERSION=1,4,0,2" - nhc98-Options: -K4M + if flag(git-rev) + build-depends: + , githash ^>= 0.1.7.0 + cpp-options: -DGIT_REV - Exposed-Modules: - Distribution.Compiler, - Distribution.Extension, - Distribution.Setup, - Distribution.InstalledPackageInfo, - Distribution.License, - Distribution.Make, - Distribution.Package, - Distribution.PackageDescription, - Distribution.PackageDescription.Configuration, - Distribution.PackageDescription.Check, - Distribution.ParseUtils, - Distribution.ReadE, - Distribution.Simple, - Distribution.Simple.Build, - Distribution.Simple.BuildPaths, - Distribution.Simple.Command, - Distribution.Simple.Compiler, - Distribution.Simple.Configure, - Distribution.Simple.GHC, - Distribution.Simple.Haddock, - Distribution.Simple.Hugs, - Distribution.Simple.Install, - Distribution.Simple.InstallDirs, - Distribution.Simple.JHC, - Distribution.Simple.LocalBuildInfo, - Distribution.Simple.NHC, - Distribution.Simple.PackageIndex, - Distribution.Simple.PreProcess, - Distribution.Simple.PreProcess.Unlit, - Distribution.Simple.Program, - Distribution.Simple.Register, - Distribution.Simple.Setup, - Distribution.Simple.SetupWrapper, - Distribution.Simple.SrcDist, - Distribution.Simple.UserHooks, - Distribution.Simple.Utils, - Distribution.System, - Distribution.Text, - Distribution.Verbosity, - Distribution.Version, - Distribution.Compat.ReadP, - Language.Haskell.Extension + ghc-options: + -Wall + -fno-ignore-asserts + -Wtabs + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-unticked-promoted-constructors - Other-Modules: - Distribution.GetOpt, - Distribution.Compat.TempFile - Distribution.Simple.GHC.Makefile + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances - Extensions: CPP + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + exposed-modules: + Distribution.Backpack.Configure + Distribution.Backpack.ComponentsGraph + Distribution.Backpack.ConfiguredComponent + Distribution.Backpack.DescribeUnitId + Distribution.Backpack.FullUnitId + Distribution.Backpack.LinkedComponent + Distribution.Backpack.ModSubst + Distribution.Backpack.ModuleShape + Distribution.Backpack.PreModuleShape + Distribution.Utils.IOData + Distribution.Utils.LogProgress + Distribution.Utils.MapAccum + Distribution.Compat.CreatePipe + Distribution.Compat.Directory + Distribution.Compat.Environment + Distribution.Compat.FilePath + Distribution.Compat.Internal.TempFile + Distribution.Compat.ResponseFile + Distribution.Compat.Prelude.Internal + Distribution.Compat.Process + Distribution.Compat.Stack + Distribution.Compat.Time + Distribution.Make + Distribution.PackageDescription.Check + Distribution.ReadE + Distribution.Simple + Distribution.Simple.Bench + Distribution.Simple.Build + Distribution.Simple.Build.Inputs + Distribution.Simple.Build.Macros + Distribution.Simple.Build.PackageInfoModule + Distribution.Simple.Build.PathsModule + Distribution.Simple.BuildPaths + Distribution.Simple.BuildTarget + Distribution.Simple.BuildToolDepends + Distribution.Simple.BuildWay + Distribution.Simple.CCompiler + Distribution.Simple.Command + Distribution.Simple.Compiler + Distribution.Simple.Configure + Distribution.Simple.Errors + Distribution.Simple.FileMonitor.Types + Distribution.Simple.Flag + Distribution.Simple.GHC + Distribution.Simple.GHCJS + Distribution.Simple.Haddock + Distribution.Simple.Glob + Distribution.Simple.Glob.Internal + Distribution.Simple.Hpc + Distribution.Simple.Install + Distribution.Simple.InstallDirs + Distribution.Simple.InstallDirs.Internal + Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageDescription + Distribution.Simple.PackageIndex + Distribution.Simple.PreProcess + Distribution.Simple.PreProcess.Types + Distribution.Simple.PreProcess.Unlit + Distribution.Simple.Program + Distribution.Simple.Program.Ar + Distribution.Simple.Program.Builtin + Distribution.Simple.Program.Db + Distribution.Simple.Program.Find + Distribution.Simple.Program.GHC + Distribution.Simple.Program.HcPkg + Distribution.Simple.Program.Hpc + Distribution.Simple.Program.Internal + Distribution.Simple.Program.Ld + Distribution.Simple.Program.ResponseFile + Distribution.Simple.Program.Run + Distribution.Simple.Program.Script + Distribution.Simple.Program.Strip + Distribution.Simple.Program.Types + Distribution.Simple.Register + Distribution.Simple.Setup + Distribution.Simple.ShowBuildInfo + Distribution.Simple.SrcDist + Distribution.Simple.Test + Distribution.Simple.Test.ExeV10 + Distribution.Simple.Test.LibV09 + Distribution.Simple.Test.Log + Distribution.Simple.UHC + Distribution.Simple.UserHooks + Distribution.Simple.SetupHooks.Errors + Distribution.Simple.SetupHooks.Internal + Distribution.Simple.SetupHooks.Rule + Distribution.Simple.Utils + Distribution.TestSuite + Distribution.Types.AnnotatedId + Distribution.Types.ComponentInclude + Distribution.Types.DumpBuildInfo + Distribution.Types.PackageName.Magic + Distribution.Types.ComponentLocalBuildInfo + Distribution.Types.LocalBuildConfig + Distribution.Types.LocalBuildInfo + Distribution.Types.TargetInfo + Distribution.Types.GivenComponent + Distribution.Types.ParStrat + Distribution.Utils.Json + Distribution.Utils.NubList + Distribution.Utils.Progress + Distribution.Verbosity + Distribution.Verbosity.Internal + + -- We reexport all of Cabal-syntax to aid in compatibility for downstream + -- users. In the future we may opt to deprecate some or all of these exports. + -- See haskell/Cabal#7974. + reexported-modules: + Distribution.Backpack, + Distribution.CabalSpecVersion, + Distribution.Compat.Binary, + Distribution.Compat.CharParsing, + Distribution.Compat.DList, + Distribution.Compat.Exception, + Distribution.Compat.Graph, + Distribution.Compat.Lens, + Distribution.Compat.MonadFail, + Distribution.Compat.Newtype, + Distribution.Compat.NonEmptySet, + Distribution.Compat.Parsing, + Distribution.Compat.Prelude, + Distribution.Compat.Semigroup, + Distribution.Compiler, + Distribution.FieldGrammar, + Distribution.FieldGrammar.Class, + Distribution.FieldGrammar.FieldDescrs, + Distribution.FieldGrammar.Newtypes, + Distribution.FieldGrammar.Parsec, + Distribution.FieldGrammar.Pretty, + Distribution.Fields, + Distribution.Fields.ConfVar, + Distribution.Fields.Field, + Distribution.Fields.Lexer, + Distribution.Fields.LexerMonad, + Distribution.Fields.ParseResult, + Distribution.Fields.Parser, + Distribution.Fields.Pretty, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.FieldGrammar, + Distribution.PackageDescription.Parsec, + Distribution.PackageDescription.PrettyPrint, + Distribution.PackageDescription.Quirks, + Distribution.PackageDescription.Utils, + Distribution.Parsec, + Distribution.Parsec.Error, + Distribution.Parsec.FieldLineStream, + Distribution.Parsec.Position, + Distribution.Parsec.Warning, + Distribution.Pretty, + Distribution.SPDX, + Distribution.SPDX.License, + Distribution.SPDX.LicenseExceptionId, + Distribution.SPDX.LicenseExpression, + Distribution.SPDX.LicenseId, + Distribution.SPDX.LicenseListVersion, + Distribution.SPDX.LicenseReference, + Distribution.System, + Distribution.Text, + Distribution.Types.AbiDependency, + Distribution.Types.AbiHash, + Distribution.Types.Benchmark, + Distribution.Types.Benchmark.Lens, + Distribution.Types.BenchmarkInterface, + Distribution.Types.BenchmarkType, + Distribution.Types.BuildInfo, + Distribution.Types.BuildInfo.Lens, + Distribution.Types.BuildType, + Distribution.Types.Component, + Distribution.Types.ComponentId, + Distribution.Types.ComponentName, + Distribution.Types.ComponentRequestedSpec, + Distribution.Types.CondTree, + Distribution.Types.Condition, + Distribution.Types.ConfVar, + Distribution.Types.Dependency, + Distribution.Types.DependencyMap, + Distribution.Types.DependencySatisfaction, + Distribution.Types.ExeDependency, + Distribution.Types.Executable, + Distribution.Types.Executable.Lens, + Distribution.Types.ExecutableScope, + Distribution.Types.ExposedModule, + Distribution.Types.Flag, + Distribution.Types.ForeignLib, + Distribution.Types.ForeignLib.Lens, + Distribution.Types.ForeignLibOption, + Distribution.Types.ForeignLibType, + Distribution.Types.GenericPackageDescription, + Distribution.Types.GenericPackageDescription.Lens, + Distribution.Types.HookedBuildInfo, + Distribution.Types.IncludeRenaming, + Distribution.Types.InstalledPackageInfo, + Distribution.Types.InstalledPackageInfo.Lens, + Distribution.Types.InstalledPackageInfo.FieldGrammar, + Distribution.Types.LegacyExeDependency, + Distribution.Types.Lens, + Distribution.Types.Library, + Distribution.Types.Library.Lens, + Distribution.Types.LibraryName, + Distribution.Types.LibraryVisibility, + Distribution.Types.MissingDependency, + Distribution.Types.MissingDependencyReason, + Distribution.Types.Mixin, + Distribution.Types.Module, + Distribution.Types.ModuleReexport, + Distribution.Types.ModuleRenaming, + Distribution.Types.MungedPackageId, + Distribution.Types.MungedPackageName, + Distribution.Types.PackageDescription, + Distribution.Types.PackageDescription.Lens, + Distribution.Types.PackageId, + Distribution.Types.PackageId.Lens, + Distribution.Types.PackageName, + Distribution.Types.PackageVersionConstraint, + Distribution.Types.PkgconfigDependency, + Distribution.Types.PkgconfigName, + Distribution.Types.PkgconfigVersion, + Distribution.Types.PkgconfigVersionRange, + Distribution.Types.SetupBuildInfo, + Distribution.Types.SetupBuildInfo.Lens, + Distribution.Types.SourceRepo, + Distribution.Types.SourceRepo.Lens, + Distribution.Types.TestSuite, + Distribution.Types.TestSuite.Lens, + Distribution.Types.TestSuiteInterface, + Distribution.Types.TestType, + Distribution.Types.UnitId, + Distribution.Types.UnqualComponentName, + Distribution.Types.Version, + Distribution.Types.VersionInterval, + Distribution.Types.VersionInterval.Legacy, + Distribution.Types.VersionRange, + Distribution.Types.VersionRange.Internal, + Distribution.Utils.Base62, + Distribution.Utils.Generic, + Distribution.Utils.MD5, + Distribution.Utils.Path, + Distribution.Utils.ShortText, + Distribution.Utils.String, + Distribution.Utils.Structured, + Distribution.Version, + Language.Haskell.Extension + + -- Parsec parser-related modules + build-depends: + -- transformers-0.4.0.0 doesn't have record syntax e.g. for Identity + -- See also https://github.com/ekmett/transformers-compat/issues/35 + , transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.7) + , mtl >= 2.1 && < 2.4 + , parsec >= 3.1.13.0 && < 3.2 + + other-modules: + Distribution.Backpack.PreExistingComponent + Distribution.Backpack.ReadyComponent + Distribution.Backpack.MixLink + Distribution.Backpack.ModuleScope + Distribution.Backpack.UnifyM + Distribution.Backpack.Id + Distribution.Utils.UnionFind + Distribution.Compat.Async + Distribution.Compat.CopyFile + Distribution.Compat.GetShortPathName + Distribution.Compat.SnocList + Distribution.GetOpt + Distribution.Lex + Distribution.PackageDescription.Check.Common + Distribution.PackageDescription.Check.Conditional + Distribution.PackageDescription.Check.Monad + Distribution.PackageDescription.Check.Paths + Distribution.PackageDescription.Check.Target + Distribution.PackageDescription.Check.Warning + Distribution.Simple.Build.Macros.Z + Distribution.Simple.Build.PackageInfoModule.Z + Distribution.Simple.Build.PathsModule.Z + Distribution.Simple.GHC.Build + Distribution.Simple.GHC.Build.ExtraSources + Distribution.Simple.GHC.Build.Link + Distribution.Simple.GHC.Build.Modules + Distribution.Simple.GHC.Build.Utils + Distribution.Simple.GHC.EnvironmentParser + Distribution.Simple.GHC.Internal + Distribution.Simple.GHC.ImplInfo + Distribution.Simple.ConfigureScript + Distribution.Simple.Setup.Benchmark + Distribution.Simple.Setup.Build + Distribution.Simple.Setup.Clean + Distribution.Simple.Setup.Common + Distribution.Simple.Setup.Config + Distribution.Simple.Setup.Copy + Distribution.Simple.Setup.Global + Distribution.Simple.Setup.Haddock + Distribution.Simple.Setup.Hscolour + Distribution.Simple.Setup.Install + Distribution.Simple.Setup.Register + Distribution.Simple.Setup.Repl + Distribution.Simple.Setup.SDist + Distribution.Simple.Setup.Test + Distribution.ZinzaPrelude + Paths_Cabal + + autogen-modules: + Paths_Cabal + + other-extensions: + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + LambdaCase + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,1046 @@ +# 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.1.0.md + +# 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.0.0.md + +# 3.14.2.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) April 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.2.0.md + +# 3.14.1.0 [Hécate](mailto:hecate+github@glitchbra.in) November 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.1.0.md + +# 3.14.0.0 [Hécate](mailto:hecate+github@glitchbra.in) September 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.0.0.md + +# 3.12.1.0 [Artem Pelenitsyn](mailto:a.pelenitsyn@gmail.com) June 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.1.0.md + +# 3.12.0.0 [Francesco Ariis](mailto:fa-ml@ariis.it) May 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.0.0.md + +# 3.10.3.0 [Hécate](mailto:hecate+github@glitchbra.in) January 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.3.0.md + +# 3.10.2.1 [Hécate](mailto:hecate+github@glitchbra.in) October 2023 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.1.md + +# 3.10.2.0 [Hécate](mailto:hecate+github@glitchbra.in) August 2023 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.0.md + +# 3.10.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) March 2023 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.1.0.md + +# 3.8.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) August 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.8.1.0.md + +# 3.6.3.0 March 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.3.0.md + +# 3.6.2.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.2.0.md + +# 3.6.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.1.0.md + +# 3.6.0.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.0.0.md + +# 3.4.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.1.0.md + +# 3.4.0.0 [Oleg Grenrus](mailto:oleg.grnerus@iki.fi) February 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.0.0.md + +# 3.2.1.0 [Oleg Grenrus](mailto:oleg.grenris@iki.fi) October 2020 + * Pass `cxx-options` with `-optcxx` for GHC >= 8.10 + * Use process jobs when calling subprocesses + * Require custom-setup for `cabal-version: 1.24` and later + * Accept `linux-androideabi` as an alias for Android + * Fix ghci being launched before other sources are built + * Require cabal-versions >=1.25 to be exact + +# 3.2.0.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020 + * Change free text `String` fields to use `ShortText` in package description + and installed package info. + * Split `Distribution.Types.Flag` and `Distribution.Types.ConfVar` + `Distribution.Types.GenericPackageDescription`. + * Add GHC-8.10 support, including new extensions to + `Language.Haskell.Extension`. + * Use more `NonEmpty` instead of ordinary lists. + * Add `Distribution.Utils.Structured` for fingeprinting `Binary` blobs. + * Add `null`, `length` and `unsafeFromUTF8BS` to `Distribution.Utils.ShortText`. + * Refactor `Distribution.Utils.IOData` module. + * Rename `Distribution.Compat.MD5` to `Distribution.Utils.MD5`. + * Add `safeHead`, `safeTail`, `safeLast` to `Distribution.Utils.Generic`. + * Add `unsnoc` and `unsnocNE` to `Distribution.Utils.Generic`. + * Add `Set'` modifier to `Distribution.Parsec.Newtypes`. + * Add `Distribution.Compat.Async`. + +# 3.0.2.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020 + * Disallow spaces around colon `:` in Dependency `build-depends` syntax + ([#6538](https://github.com/haskell/cabal/pull/6538)). + * Make `configure` accept any `pkg-config --modversion` output + ([#6541](https://github.com/haskell/cabal/pull/6541)). + +# 3.0.1.0 [Herbert Valerio Riedel](mailto:hvr@gnu.org) April 2020 + * Add GHC-8.8 flags to `normaliseGhcFlags` + ([#6379](https://github.com/haskell/cabal/pull/6379)). + * Typo fixes + ([#6372](https://github.com/haskell/cabal/pull/6372)). + * Limit version number parts to contain at most 9 digits + ([#6386](https://github.com/haskell/cabal/pull/6386)). + * Fix boundless sublibrary dependency parse failure + ([#5846](https://github.com/haskell/cabal/issues/5846)). + * `cabal check` verifies `cpp-options` more pedantically, allowing only + options starting with `-D` and `-U`. + * Don’t rebuild world when new ghc flags that affect how error + messages are presented is specified. + * Fix dropExeExtension behaviour on Windows + ([#6287](https://github.com/haskell/cabal/pull/6287)). + +# 3.0.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) August 2019 + * The 3.0 migration guide gives advice on adapting Custom setup + scripts to backwards-incompatible changes in this release: + https://github.com/haskell/cabal/wiki/3.0-migration-guide. + * Due to [#5119](https://github.com/haskell/cabal/issues/5119), the + `cabal check` warning for bounds on internal libraries has been + disabled. + * Introduce set notation for `^>=` and `==` operators + ([#5906](https://github.com/haskell/cabal/pull/5906)). + * 'check' reports warnings for various ghc-\*-options fields separately + ([#5342](https://github.com/haskell/cabal/issues/5432)). + * `KnownExtension`: added new extensions `DerivingVia` and + `EmptyDataDeriving`. + * Add `extra-dynamic-library-flavours`, to specify extra dynamic library + flavours to build and install from a .cabal file. + * `autoconfUserHooks` now passes `--host=$HOST` when cross-compiling + * Introduce multiple public libraries feature + ([#5526](https://github.com/haskell/cabal/pull/5526)). + * New build-depends syntax + * Add a set of library components to the `Dependency` datatype + * New `visibility` field in the `library` stanza + * New `LibraryVisibility` field in `InstalledPackageInfo` + * New syntax for the `--dependency` Cabal flag + * Static linking + * Add `--enable-executable-static` flag for building fully + static executables (GHC's normal "statish" linking links + Haskell libraries statically, but libc and system dependencies + dynamically). This new flag links everything statically. + * Note you likely want to link against `musl` or another libc that + supports fully static linking; + [`glibc` has some issues](https://sourceware.org/glibc/wiki/FAQ#Even_statically_linked_programs_need_some_shared_libraries_which_is_not_acceptable_for_me.__What_can_I_do.3F) + with fully static linking. + * Fix corrupted config file header for non-ASCII package names + ([2557](https://github.com/haskell/cabal/issues/2557)). + * Extend `Distribution.Simple.Utils.rewriteFileEx` from ASCII to UTF-8 encoding. + * Change the arguments of `Newtype` class to better suit @DeriveAnyClass@ usage, + add default implementation in terms of `coerce` / `unsafeCoerce`. + * Implement support for response file arguments to defaultMain* and cabal-install. + * Uniformly provide 'Semigroup' instances for `base < 4.9` via `semigroups` package + * Implement `{cmm,asm}-{sources,options} buildinfo fields for + separate compilation of C-- and ASM source files (#6033). + * Setting `debug-info` now implies `library-stripping: False` and + `executable-stripping: False) ([#2702](https://github.com/haskell/cabal/issues/2702)) + * `Setup.hs copy` and `install` now work in the presence of + `data-files` that use `**` syntax + ([#6125](https://github.com/haskell/cabal/issues/6125)). + +---- + +### 2.4.1.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) December 2018 + + * Fix `--with-compiler` failing to locate compiler on Windows + ([#5753](https://github.com/haskell/cabal/pull/5753)). + * Cabal can once again be built with GHC 7.8 and 7.6 + ([#5730](https://github.com/haskell/cabal/pull/5730)). + +### 2.4.1.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) November 2018 + + * Warnings in autogenerated files are now silenced + ([#5678](https://github.com/haskell/cabal/pull/5678)). + * Improved recompilation avoidance, especially when using GHC 8.6 + ([#5589](https://github.com/haskell/cabal/pull/5589)). + * Do not error on empty packagedbs in `getInstalledPackages` + ([#5516](https://github.com/haskell/cabal/issues/5516)). + + +### 2.4.0.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) September 2018 + + * Allow arguments to be passed to `Setup.hs haddock` for `build-type:configure` + ([#5503](https://github.com/haskell/cabal/issues/5503)). + +# 2.4.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) September 2018 + * Due to [#5119](https://github.com/haskell/cabal/issues/5119), the + `cabal check` warning for bounds on internal libraries has been + disabled. + * `Distribution.Simple.Haddock` now checks to ensure that it + does not erroneously call Haddock with no target modules. + ([#5232](https://github.com/haskell/cabal/issues/5232), + [#5459](https://github.com/haskell/cabal/issues/5459)). + * Add `getting` (less general than `to`) Lens combinator, + `non`) and an optics to access the modules in a component + of a `PackageDescription` by the `ComponentName`: + `componentBuildInfo` and `componentModules` + * Linker `ld-options` are now passed to GHC as `-optl` options + ([#4925](https://github.com/haskell/cabal/pull/4925)). + * Add `readGhcEnvironmentFile` to parse GHC environment files. + * Drop support for GHC 7.4, since it is out of our support window + (and has been for over a year!) + * Deprecate `preSDist`, `sDistHook`, and `postSDist` in service of + `new-sdist`, since they violate key invariants of the new-build + ecosystem. Use `autogen-modules` and `build-tool-depends` instead. + ([#5389](https://github.com/haskell/cabal/pull/5389)). + * Added `--repl-options` flag to `Setup repl` used to pass flags to the + underlying repl without affecting the `LocalBuildInfo` + ([#4247](https://github.com/haskell/cabal/issues/4247), + [#5287](https://github.com/haskell/cabal/pull/5287)) + * `KnownExtension`: added new extensions `BlockArguments` + ([#5101](https://github.com/haskell/cabal/issues/5101)), + `NumericUnderscores` + ([#5130]((https://github.com/haskell/cabal/issues/5130)), + `QuantifiedConstraints`, and `StarIsType`. + * `buildDepends` is removed from `PackageDescription`. It had long been + uselessly hanging about as top-level build-depends already got put + into per-component condition trees anyway. Now it's finally been put + out of its misery + ([#4383](https://github.com/haskell/cabal/issues/4283)). + * Added `Eta` to `CompilerFlavor` and to known compilers. + * `cabal haddock` now generates per-component documentation + ([#5226](https://github.com/haskell/cabal/issues/5226)). + * Wildcard improvements: + * Allow `**` wildcards in `data-files`, `extra-source-files` and + `extra-doc-files`. These allow a limited form of recursive + matching, and require `cabal-version: 2.4`. + ([#5284](https://github.com/haskell/cabal/issues/5284), + [#3178](https://github.com/haskell/cabal/issues/3178), et al.) + * With `cabal-version: 2.4`, when matching a wildcard, the + requirement for the full extension to match exactly has been + loosened. Instead, if the wildcard's extension is a suffix of the + file's extension, the file will be selected. For example, + previously `foo.en.html` would not match `*.html`, and + `foo.solaris.tar.gz` would not match `*.tar.gz`, but now both + do. This may lead to files unexpectedly being included by `sdist`; + please audit your package descriptions if you rely on this + behaviour to keep sensitive data out of distributed packages + ([#5372](https://github.com/haskell/cabal/pull/5372), + [#784](https://github.com/haskell/cabal/issues/784), + [#5057](https://github.com/haskell/cabal/issues/5057)). + * Wildcard syntax errors (misplaced `*`, etc), wildcards that + refer to missing directories, and wildcards that do not match + anything are now all detected by `cabal check`. + * Wildcard ('globbing') functions have been moved from + `Distribution.Simple.Utils` to `Distribution.Simple.Glob` and + have been refactored. + * Fixed `cxx-options` and `cxx-sources` buildinfo fields for + separate compilation of C++ source files to correctly build and link + non-library components ([#5309](https://github.com/haskell/cabal/issues/5309)). + * Reduced warnings generated by hsc2hs and c2hs when `cxx-options` field + is present in a component. + * `cabal check` now warns if `-j` is used in `ghc-options` in a Cabal + file. ([#5277](https://github.com/haskell/cabal/issues/5277)) + * `install-includes` now works as expected with foreign libraries + ([#5302](https://github.com/haskell/cabal/issues/5299)). + * Removed support for JHC. + * Options listed in `ghc-options`, `cc-options`, `ld-options`, + `cxx-options`, `cpp-options` are not deduplicated anymore + ([#4449](https://github.com/haskell/cabal/issues/4449)). + * Deprecated `cabal hscolour` in favour of `cabal haddock --hyperlink-source` ([#5236](https://github.com/haskell/cabal/pull/5236/)). + * Recognize `powerpc64le` as architecture PPC64. + * Cabal now deduplicates more `-I` and `-L` and flags to avoid `E2BIG` + ([#5356](https://github.com/haskell/cabal/issues/5356)). + * With `build-type: configure`, avoid using backslashes to delimit + path components on Windows and warn about other unsafe characters + in the path to the source directory on all platforms + ([#5386](https://github.com/haskell/cabal/issues/5386)). + * `Distribution.PackageDescription.Check.checkPackageFiles` now + accepts a `Verbosity` argument. + * Added a parameter to + `Distribution.Backpack.ConfiguredComponent.toConfiguredComponent` in order to fix + [#5409](https://github.com/haskell/cabal/issues/5409). + * Partially silence `abi-depends` warnings + ([#5465](https://github.com/haskell/cabal/issues/5465)). + * Foreign libraries are now linked against the threaded RTS when the + 'ghc-options: -threaded' flag is used + ([#5431](https://github.com/haskell/cabal/pull/5431)). + * Pass command line arguments to `hsc2hs` using response files when possible + ([#3122](https://github.com/haskell/cabal/issues/3122)). + +---- + +## 2.2.0.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) March 2018 + + * Fix `checkPackageFiles` for relative directories ([#5206](https://github.com/haskell/cabal/issues/5206)) + + +# 2.2.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) March 2018 + + * The 2.2 migration guide gives advice on adapting Custom setup + scripts to backwards-incompatible changes in this release: + https://github.com/haskell/cabal/wiki/2.2-migration-guide. + * New Parsec-based parser for `.cabal` files is now the + default. This brings memory consumption and speed improvements, as + well as making new syntax extensions easier to implement. + * Support for common stanzas (#4751). + * Added elif-conditionals to `.cabal` syntax (#4750). + * The package license information can now be specified using the + SPDX syntax. This requires setting `cabal-version` to 2.2+ (#2547, + #5050). + * Support for GHC's numeric -g debug levels (#4673). + * Compilation with section splitting is now supported via the + `--enable-split-sections` flag (#4819) + * Fields with mandatory commas (e.g. build-depends) may now have a + leading or a trailing comma (either one, not both) (#4953) + * Added `virtual-modules` field, to allow modules that are not built + but registered (#4875). + * Use better defaulting for `build-type`; rename `PackageDescription`'s + `buildType` field to `buildTypeRaw` and introduce new `buildType` + function (#4958) + * `D.T.PackageDescription.allBuildInfo` now returns all build infos, not + only for buildable components (#5087). + * Removed `UnknownBuildType` constructor from `BuildType` (#5003). + * Added `HexFloatLiterals` to `KnownExtension`. + * Cabal will no longer try to build an empty set of `inputModules` + (#4890). + * `copyComponent` and `installIncludeFiles` will now look for + include headers in the build directory (`dist/build/...` by + default) as well (#4866). + * Added `cxx-options` and `cxx-sources` buildinfo fields for + separate compilation of C++ source files (#3700). + * Removed unused `--allow-newer`/`--allow-older` support from + `Setup configure` (#4527). + * Changed `FlagAssignment` to be an opaque `newtype` (#4849). + * Changed `rawSystemStdInOut` to use proper type to represent + binary and textual data; new `Distribution.Utils.IOData` module; + removed obsolete `startsWithBOM`, `fileHasBOM`, `fromUTF8`, + and `toUTF8` functions; add new `toUTF8BS`/`toUTF8LBS` + encoding functions. (#4666) + * Added a `cabal check` warning when the `.cabal` file name does + not match package name (#4592). + * The `ar` program now receives its arguments via a response file + (`@file`). Old behaviour can be restored with + `--disable-response-files` argument to `configure` or + `install` (#4596). + * Added `.Lens` modules, with optics for package description data + types (#4701). + * Support for building with Win32 version 2.6 (#4835). + * Change `compilerExtensions` and `ghcOptExtensionMap` to contain + `Maybe Flag`s, since a supported extension can lack a flag (#4443). + * Pretty-printing of `.cabal` files is slightly different due to + parser changes. For an example, see + https://mail.haskell.org/pipermail/cabal-devel/2017-December/010414.html. + * `--hyperlink-source` now uses Haddock's hyperlinker backend when + Haddock is new enough, falling back to HsColour otherwise. + * `D.S.defaultHookedPackageDesc` has been deprecated in favour of + `D.S.findHookedPackageDesc` (#4874). + * `D.S.getHookedBuildInfo` now takes an additional parameter + specifying the build directory path (#4874). + * Emit warning when encountering unknown GHC versions (#415). + +### 2.0.1.1 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) December 2017 + + * Don't pass `other-modules` to stub executable for detailed-0.9 + (#4918). + * Hpc: Use relative .mix search paths (#4917). + +## 2.0.1.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) November 2017 + + * Support for GHC's numeric -g debug levels (#4673). + * Added a new `Distribution.Verbosity.modifyVerbosity` combinator + (#4724). + * Added a new `cabal check` warning about unused, undeclared or + non-Unicode flags. Also, it warns about leading dash, which is + unusable but accepted if it's unused in conditionals. (#4687) + * Modify `allBuildInfo` to include foreign library info (#4763). + * Documentation fixes. + +### 2.0.0.2 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) July 2017 + + * See http://coldwa.st/e/blog/2017-09-09-Cabal-2-0.html + for more detailed release notes. + * The 2.0 migration guide gives advice on adapting Custom setup + scripts to backwards-incompatible changes in this release: + https://github.com/haskell/cabal/wiki/2.0-migration-guide + * Add CURRENT_PACKAGE_VERSION to cabal_macros.h (#4319) + * Dropped support for versions of GHC earlier than 6.12 (#3111). + * GHC compatibility window for the Cabal library has been extended + to five years (#3838). + * Convenience/internal libraries are now supported (#269). + An internal library is declared using the stanza `library + 'libname'`. Packages which use internal libraries can + result in multiple registrations; thus `--gen-pkg-config` + can now output a directory of registration scripts rather than + a single file. + * Backwards incompatible change to preprocessor interface: + the function in `PPSuffixHandler` now takes an additional + `ComponentLocalBuildInfo` specifying the build information + of the component being preprocessed. + * Backwards incompatible change to `cabal_macros.h` (#1893): we now + generate a macro file for each component which contains only + information about the direct dependencies of that component. + Consequently, `dist/build/autogen/cabal_macros.h` contains + only the macros for the library, and is not generated if a + package has no library; to find the macros for an executable + named `foobar`, look in `dist/build/foobar/autogen/cabal_macros.h`. + Similarly, if you used `autogenModulesDir` you should now + use `autogenComponentModulesDir`, which now requires a + `ComponentLocalBuildInfo` argument as well in order to + disambiguate which component the autogenerated files are for. + * Backwards incompatible change to `Component`: `TestSuite` and + `Benchmark` no longer have `testEnabled` and + `benchmarkEnabled`. If you used + `enabledTests` or `enabledBenchmarks`, please instead use + `enabledTestLBIs` and `enabledBenchLBIs` + (you will need a `LocalBuildInfo` for these functions.) + Additionally, the semantics of `withTest` and `withBench` + have changed: they now iterate over all buildable + such components, regardless of whether or not they have + been enabled; if you only want enabled components, + use `withTestLBI` and `withBenchLBI`. + `finalizePackageDescription` is deprecated: + its replacement `finalizePD` now takes an extra argument + `ComponentRequestedSpec` which specifies what components + are to be enabled: use this instead of modifying the + `Component` in a `GenericPackageDescription`. (As + it's not possible now, `finalizePackageDescription` + will assume tests/benchmarks are disabled.) + If you only need to test if a component is buildable + (i.e., it is marked buildable in the Cabal file) + use the new function `componentBuildable`. + * Backwards incompatible change to `PackageName` (#3896): + `PackageName` is now opaque; conversion to/from `String` now works + via (old) `unPackageName` and (new) `mkPackageName` functions. + * Backwards incompatible change to `ComponentId` (#3917): + `ComponentId` is now opaque; conversion to/from `String` now works + via `unComponentId` and `mkComponentId` functions. + * Backwards incompatible change to `AbiHash` (#3921): + `AbiHash` is now opaque; conversion to/from `String` now works + via `unAbiHash` and `mkAbiHash` functions. + * Backwards incompatible change to `FlagName` (#4062): + `FlagName` is now opaque; conversion to/from `String` now works + via `unFlagName` and `mkFlagName` functions. + * Backwards incompatible change to `Version` (#3905): + Version is now opaque; conversion to/from `[Int]` now works + via `versionNumbers` and `mkVersion` functions. + * Add support for `--allow-older` (dual to `--allow-newer`) (#3466) + * Improved an error message for process output decoding errors + (#3408). + * `getComponentLocalBuildInfo`, `withComponentsInBuildOrder` + and `componentsInBuildOrder` are deprecated in favor of a + new interface in `Distribution.Types.LocalBuildInfo`. + * New `autogen-modules` field. Modules that are built automatically at + setup, like Paths_PACKAGENAME or others created with a build-type + custom, appear on `other-modules` for the Library, Executable, + Test-Suite or Benchmark stanzas or also on `exposed-modules` for + libraries but are not really on the package when distributed. This + makes commands like sdist fail because the file is not found, so with + this new field modules that appear there are treated the same way as + Paths_PACKAGENAME was and there is no need to create complex build + hooks. Just add the module names on `other-modules` and + `exposed-modules` as always and on the new `autogen-modules` besides. + (#3656). + * New `./Setup configure` flag `--cabal-file`, allowing multiple + `.cabal` files in a single directory (#3553). Primarily intended for + internal use. + * Macros in `cabal_macros.h` are now ifndef'd, so that they + don't cause an error if the macro is already defined. (#3041) + * `./Setup configure` now accepts a single argument specifying + the component to be configured. The semantics of this mode + of operation are described in + + * Internal `build-tools` dependencies are now added to PATH + upon invocation of GHC, so that they can be conveniently + used via `-pgmF`. (#1541) + * Add support for new caret-style version range operator `^>=` (#3705) + * Verbosity `-v` now takes an extended format which allows + specifying exactly what you want to be logged. The format is + `[silent|normal|verbose|debug] flags`, where flags is a space + separated list of flags. At the moment, only the flags + +callsite and +callstack are supported; these report the + call site/stack of a logging output respectively (these + are only supported if Cabal is built with GHC 8.0/7.10.2 + or greater, respectively). + * New `Distribution.Utils.ShortText.ShortText` type for representing + short text strings compactly (#3898) + * Cabal no longer supports using a version bound to disambiguate + between an internal and external package (#4020). This should + not affect many people, as this mode of use already did not + work with the dependency solver. + * Support for "foreign libraries" (#2540), which are Haskell + libraries intended to be used by foreign languages like C. + Foreign libraries only work with GHC 7.8 and later. + * Added a technical preview version of integrated doctest support (#4480). + * Added a new `scope` field to the executable stanza. Executables + with `scope: private` get installed into + $libexecdir/$libexecsubdir. Additionally $libexecdir now has a + subdir structure similar to $lib(sub)dir to allow installing + private executables of different packages and package versions + alongside one another. Private executables are those that are + expected to be run by other programs rather than users. (#3461) + +## 1.24.2.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) December 2016 + * Fixed a bug in the handling of non-buildable components (#4094). + * Reverted a PVP-noncompliant API change in 1.24.1.0 (#4123). + * Bumped the directory upper bound to < 1.4 (#4158). + +## 1.24.1.0 [Ryan Thomas](mailto:ryan@ryant.org) October 2016 + * API addition: `differenceVersionRanges` (#3519). + * Fixed reexported-modules display mangling (#3928). + * Check that the correct cabal-version is specified when the + extra-doc-files field is present (#3825). + * Fixed an incorrect invocation of GetShortPathName that was + causing build failures on Windows (#3649). + * Linker flags are now set correctly on GHC >= 7.8 (#3443). + +# 1.24.0.0 [Ryan Thomas](mailto:ryan@ryant.org) March 2016 + * Support GHC 8. + * Deal with extra C sources from preprocessors (#238). + * Include cabal_macros.h when running c2hs (#2600). + * Don't recompile C sources unless needed (#2601). + * Read `builddir` option from `CABAL_BUILDDIR` environment variable. + * Add `--profiling-detail=$level` flag with a default for libraries + and executables of `exported-functions` and `toplevel-functions` + respectively (GHC's `-fprof-auto-{exported,top}` flags) (#193). + * New `custom-setup` stanza to specify setup deps. Setup is also built + with the cabal_macros.h style macros, for conditional compilation. + * Support Haddock response files (#2746). + * Fixed a bug in the Text instance for Platform (#2862). + * New `setup haddock` option: `--for-hackage` (#2852). + * New `--show-detail=direct`; like streaming, but allows the test + program to detect that is connected to a terminal, and works + reliable with a non-threaded runtime (#2911, and serves as a + work-around for #2398) + * Library support for multi-instance package DBs (#2948). + * Improved the `./Setup configure` solver (#3082, #3076). + * The `--allow-newer` option can be now used with `./Setup + configure` (#3163). + * Added a way to specify extra locations to find OS X frameworks + in (`extra-framework-dirs`). Can be used both in `.cabal` files and + as an argument to `./Setup configure` (#3158). + * Macros `VERSION_$pkgname` and `MIN_VERSION_$pkgname` are now + also generated for the current package. (#3235). + * Backpack is supported! Two new fields supported in Cabal + files: signatures and mixins; and a new flag + to setup scripts, `--instantiate-with`. See + https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst + for more details. + +---- + +## 1.22.8.0 [Ryan Thomas](mailto:ryan@ryant.org) March 2016 + * Distribution.Simple.Setup: remove job cap. Fixes #3191. + * Check all object file suffixes for recompilation. Fixes #3128. + * Move source files under `src/`. Fixes #3003. + +## 1.22.7.0 [Ryan Thomas](mailto:ryan@ryant.org) January 2016 + * Backport #3012 to the 1.22 branch + * Cabal.cabal: change build-type to Simple + * Add foldl' import + * The Cabal part for fully gcc-like response files + +## 1.22.6.0 [Ryan Thomas](mailto:ryan@ryant.org) December 2015 + * Relax upper bound to allow upcoming binary-0.8 + +## 1.22.5.0 [Ryan Thomas](mailto:ryan@ryant.org) November 2015 + * Don't recompile C sources unless needed (#2601). (Luke Iannini) + * Support Haddock response files. + * Add frameworks when linking a dynamic library. + +## 1.22.4.0 [Ryan Thomas](mailto:ryan@ryant.org) June 2015 + * Add libname install-dirs variable, use it by default. Fixes #2437. (Edward Z. Yang) + * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang) + * Workaround for #2527. (Mikhail Glushenkov) + +## 1.22.3.0 [Ryan Thomas](mailto:ryan@ryant.org) April 2015 + * Fix for the ghcjs-pkg version number handling (Luite Stegeman) + * filterConfigureFlags: filter more flags (Mikhail Glushenkov) + * Cabal check will fail on -fprof-auto passed as a ghc-option - Fixes #2479 (John Chee) + +## 1.22.2.0 [Ryan Thomas](mailto:ryan@ryant.org) March 2015 + * Don't pass `--{en,dis}able-profiling` to old setup. + * Add -Wall police + * Fix dependencies on `old-time` + * Fix test interface detailed-0.9 with GHC 7.10 + * Fix HPC tests with GHC 7.10 + * Make sure to pass the package key to ghc + * Use `--package-{name|version}` when available for Haddock when available + * Put full package name and version in library names + * Fully specify package key format, so external tools can generate it. + +# 1.22.0.0 [Johan Tibell](mailto:johan.tibell@gmail.com) January 2015 + * Support GHC 7.10. + * Experimental support for emitting DWARF debug info. + * Preliminary support for relocatable packages. + * Allow cabal to be used inside cabal exec environments. + * hpc: support multiple "ways" (e.g. profiling and vanilla). + * Support GHCJS. + * Improved command line documentation. + * Add `-none` constraint syntax for version ranges (#2093). + * Make the default doc index file path compiler/arch/os-dependent + (#2136). + * Warn instead of dying when generating documentation and hscolour + isn't installed (455f51622fa38347db62197a04bb0fa5b928ff17). + * Support the new BinaryLiterals extension + (1f25ab3c5eff311ada73c6c987061b80e9bbebd9). + * Warn about `ghc-prof-options: -auto-all` in `cabal check` (#2162). + * Add preliminary support for multiple instances of the same package + version installed side-by-side (#2002). + * New binary build config format - faster build times (#2076). + * Support module thinning and renaming (#2038). + * Add a new license type: UnspecifiedLicense (#2141). + * Remove support for Hugs and nhc98 (#2168). + * Invoke `tar` with `--formar ustar` if possible in `sdist` (#1903). + * Replace `--enable-library-coverage` with `--enable-coverage`, which + enables program coverage for all components (#1945). + * Suggest that `ExitFailure 9` is probably due to memory + exhaustion (#1522). + * Drop support for Haddock < 2.0 (#1808, #1718). + * Make `cabal test`/`cabal bench` build only what's needed for + running tests/benchmarks (#1821). + * Build shared libraries by default when linking executables dynamically. + * Build profiled libraries by default when profiling executables. + +---- + +### 1.20.0.4 [Ryan Thomas](mailto:ryan@ryant.org) January 2016 + * Cabal.cabal: change build-type to Simple. + +### 1.20.0.1 [Johan Tibell](mailto:johan.tibell@gmail.com) May 2014 + * Fix streaming test output. + +# 1.20.0.0 [Johan Tibell](mailto:johan.tibell@gmail.com) April 2014 + * Rewrite user guide + * Fix repl Ctrl+C handling + * Add haskell-suite compiler support + * Add __HADDOCK_VERSION__ define + * Allow specifying exact dependency version using hash + * Rename extra-html-files to extra-doc-files + * Add parallel build support for GHC 7.8 and later + * Don't call ranlib on OS X + * Avoid re-linking executables, test suites, and benchmarks + unnecessarily, shortening build times + * Add `--allow-newer` which allows upper version bounds to be + ignored + * Add `--enable-library-stripping` + * Add command for freezing dependencies + * Allow repl to be used outside Cabal packages + * Add `--require-sandbox` + * Don't use `--strip-unneeded` on OS X or iOS + * Add new license-files field got additional licenses + * Fix if(solaris) on some Solaris versions + * Don't use -dylib-install-name on OS X with GHC > 7.8 + * Add DragonFly as a known OS + * Improve pretty-printing of Cabal files + * Add test flag `--show-details=streaming` for real-time test output + * Add exec command + +---- + +## 1.10.2.0 [Duncan Coutts](mailto:duncan@community.haskell.org) June 2011 + * Include test suites in cabal sdist + * Fix for conditionals in test suite stanzas in `.cabal` files + * Fix permissions of directories created during install + * Fix for global builds when $HOME env var is not set + +## 1.10.1.0 [Duncan Coutts](mailto:duncan@community.haskell.org) February 2011 + * Improved error messages when test suites are not enabled + * Template parameters allowed in test `--test-option(s)` flag + * Improved documentation of the test feature + * Relaxed QA check on cabal-version when using test-suite sections + * `haddock` command now allows both `--hoogle` and `--html` at the same time + * Find ghc-version-specific instances of the hsc2hs program + * Preserve file executable permissions in sdist tarballs + * Pass gcc location and flags to ./configure scripts + * Get default gcc flags from ghc + +# 1.10.0.0 [Duncan Coutts](mailto:duncan@haskell.org) November 2010 + * New cabal test feature + * Initial support for UHC + * New default-language and other-languages fields (e.g. Haskell98/2010) + * New default-extensions and other-extensions fields + * Deprecated extensions field (for packages using cabal-version >=1.10) + * Cabal-version field must now only be of the form `>= x.y` + * Removed deprecated `--copy-prefix=` feature + * Auto-reconfigure when `.cabal` file changes + * Workaround for haddock overwriting .hi and .o files when using TH + * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) + * New cpp define VERSION_ gives string version of dependencies + * User guide source now in markdown format for easier editing + * Improved checks and error messages for C libraries and headers + * Removed BSD4 from the list of suggested licenses + * Updated list of known language extensions + * Fix for include paths to allow C code to import FFI stub.h files + * Fix for intra-package dependencies on OSX + * Stricter checks on various bits of `.cabal` file syntax + * Minor fixes for c2hs + +---- + +### 1.8.0.6 [Duncan Coutts](mailto:duncan@haskell.org) June 2010 + * Fix `register --global/--user` + +### 1.8.0.4 [Duncan Coutts](mailto:duncan@haskell.org) March 2010 + * Set dylib-install-name for dynalic libs on OSX + * Stricter configure check that compiler supports a package's extensions + * More configure-time warnings + * Hugs can compile Cabal lib again + * Default datadir now follows prefix on Windows + * Support for finding installed packages for hugs + * Cabal version macros now have proper parenthesis + * Reverted change to filter out deps of non-buildable components + * Fix for registering inplace when using a specific package db + * Fix mismatch between $os and $arch path template variables + * Fix for finding ar.exe on Windows, always pick ghc's version + * Fix for intra-package dependencies with ghc-6.12 + +# 1.8.0.2 [Duncan Coutts](mailto:duncan@haskell.org) December 2009 + * Support for GHC-6.12 + * New unique installed package IDs which use a package hash + * Allow executables to depend on the lib within the same package + * Dependencies for each component apply only to that component + (previously applied to all the other components too) + * Added new known license MIT and versioned GPL and LGPL + * More liberal package version range syntax + * Package registration files are now UTF8 + * Support for LHC and JHC-0.7.2 + * Deprecated RecordPuns extension in favour of NamedFieldPuns + * Deprecated PatternSignatures extension in favor of ScopedTypeVariables + * New VersionRange semantic view as a sequence of intervals + * Improved package quality checks + * Minor simplification in a couple `Setup.hs` hooks + * Beginnings of a unit level testsuite using QuickCheck + * Various bug fixes + * Various internal cleanups + +---- + +### 1.6.0.2 [Duncan Coutts](mailto:duncan@haskell.org) February 2009 + * New configure-time check for C headers and libraries + * Added language extensions present in ghc-6.10 + * Added support for NamedFieldPuns extension in ghc-6.8 + * Fix in configure step for ghc-6.6 on Windows + * Fix warnings in `Path_pkgname.hs` module on Windows + * Fix for exotic flags in ld-options field + * Fix for using pkg-config in a package with a lib and an executable + * Fix for building haddock docs for exes that use the Paths module + * Fix for installing header files in subdirectories + * Fix for the case of building profiling libs but not ordinary libs + * Fix read-only attribute of installed files on Windows + * Ignore ghc -threaded flag when profiling in ghc-6.8 and older + +### 1.6.0.1 [Duncan Coutts](mailto:duncan@haskell.org) October 2008 + * Export a compat function to help alex and happy + +# 1.6.0.0 [Duncan Coutts](mailto:duncan@haskell.org) October 2008 + * Support for ghc-6.10 + * Source control repositories can now be specified in `.cabal` files + * Bug report URLs can be now specified in `.cabal` files + * Wildcards now allowed in data-files and extra-source-files fields + * New syntactic sugar for dependencies `build-depends: foo ==1.2.*` + * New cabal_macros.h provides macros to test versions of dependencies + * Relocatable bindists now possible on unix via env vars + * New `exposed` field allows packages to be not exposed by default + * Install dir flags can now use $os and $arch variables + * New `--builddir` flag allows multiple builds from a single sources dir + * cc-options now only apply to .c files, not for -fvia-C + * cc-options are not longer propagated to dependent packages + * The cpp/cc/ld-options fields no longer use `,` as a separator + * hsc2hs is now called using gcc instead of using ghc as gcc + * New api for manipulating sets and graphs of packages + * Internal api improvements and code cleanups + * Minor improvements to the user guide + * Miscellaneous minor bug fixes + +---- + +### 1.4.0.2 [Duncan Coutts](mailto:duncan@haskell.org) August 2008 + * Fix executable stripping default + * Fix striping exes on OSX that export dynamic symbols (like ghc) + * Correct the order of arguments given by `--prog-options=` + * Fix corner case with overlapping user and global packages + * Fix for modules that use pre-processing and `.hs-boot` files + * Clarify some points in the user guide and readme text + * Fix verbosity flags passed to sub-command like haddock + * Fix `sdist --snapshot` + * Allow meta-packages that contain no modules or C code + * Make the generated Paths module -Wall clean on Windows + +### 1.4.0.1 [Duncan Coutts](mailto:duncan@haskell.org) June 2008 + * Fix a bug which caused `.` to always be in the sources search path + * Haddock-2.2 and later do now support the `--hoogle` flag + +# 1.4.0.0 [Duncan Coutts](mailto:duncan@haskell.org) June 2008 + * Rewritten command line handling support + * Command line completion with bash + * Better support for Haddock 2 + * Improved support for nhc98 + * Removed support for ghc-6.2 + * Haddock markup in `.lhs` files now supported + * Default colour scheme for highlighted source code + * Default prefix for `--user` installs is now `$HOME/.cabal` + * All `.cabal` files are treaded as UTF-8 and must be valid + * Many checks added for common mistakes + * New `--package-db=` option for specific package databases + * Many internal changes to support cabal-install + * Stricter parsing for version strings, eg disallows "1.05" + * Improved user guide introduction + * Programatica support removed + * New options `--program-prefix/suffix` allows eg versioned programs + * Support packages that use `.hs-boot` files + * Fix sdist for Main modules that require preprocessing + * New configure -O flag with optimisation level 0--2 + * Provide access to "`x-`" extension fields through the Cabal api + * Added check for broken installed packages + * Added warning about using inconsistent versions of dependencies + * Strip binary executable files by default with an option to disable + * New options to add site-specific include and library search paths + * Lift the restriction that libraries must have exposed-modules + * Many bugs fixed. + * Many internal structural improvements and code cleanups + +---- + +## 1.2.4.0 [Duncan Coutts](mailto:duncan@haskell.org) June 2008 + * Released with GHC 6.8.3 + * Backported several fixes and minor improvements from Cabal-1.4 + * Use a default colour scheme for sources with hscolour >=1.9 + * Support `--hyperlink-source` for Haddock >= 2.0 + * Fix for running in a non-writable directory + * Add OSX -framework arguments when linking executables + * Updates to the user guide + * Allow build-tools names to include + and _ + * Export autoconfUserHooks and simpleUserHooks + * Export ccLdOptionsBuildInfo for `Setup.hs` scripts + * Export unionBuildInfo and make BuildInfo an instance of Monoid + * Fix to allow the `main-is` module to use a pre-processor + +## 1.2.3.0 [Duncan Coutts](mailto:duncan@haskell.org) Nov 2007 + * Released with GHC 6.8.2 + * Includes full list of GHC language extensions + * Fix infamous `dist/conftest.c` bug + * Fix `configure --interfacedir=` + * Find ld.exe on Windows correctly + * Export PreProcessor constructor and mkSimplePreProcessor + * Fix minor bug in unlit code + * Fix some markup in the haddock docs + +## 1.2.2.0 [Duncan Coutts](mailto:duncan@haskell.org) Nov 2007 + * Released with GHC 6.8.1 + * Support haddock-2.0 + * Support building DSOs with GHC + * Require reconfiguring if the `.cabal` file has changed + * Fix os(windows) configuration test + * Fix building documentation + * Fix building packages on Solaris + * Other minor bug fixes + +## 1.2.1 [Duncan Coutts](mailto:duncan@haskell.org) Oct 2007 + * To be included in GHC 6.8.1 + * New field `cpp-options` used when preprocessing Haskell modules + * Fixes for hsc2hs when using ghc + * C source code gets compiled with -O2 by default + * OS aliases, to allow os(windows) rather than requiring os(mingw32) + * Fix cleaning of `stub` files + * Fix cabal-setup, command line ui that replaces `runhaskell Setup.hs` + * Build docs even when dependent packages docs are missing + * Allow the `--html-dir` to be specified at configure time + * Fix building with ghc-6.2 + * Other minor bug fixes and build fixes + +# 1.2.0 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) Sept 2007 + * To be included in GHC 6.8.x + * New configurations feature + * Can make haddock docs link to highlighted sources (with hscolour) + * New flag to allow linking to haddock docs on the web + * Supports pkg-config + * New field `build-tools` for tool dependencies + * Improved c2hs support + * Preprocessor output no longer clutters source dirs + * Separate `includes` and `install-includes` fields + * Makefile command to generate makefiles for building libs with GHC + * New `--docdir` configure flag + * Generic `--with-prog` `--prog-args` configure flags + * Better default installation paths on Windows + * Install paths can be specified relative to each other + * License files now installed + * Initial support for NHC (incomplete) + * Consistent treatment of verbosity + * Reduced verbosity of configure step by default + * Improved helpfulness of output messages + * Help output now clearer and fits in 80 columns + * New setup register `--gen-pkg-config` flag for distros + * Major internal refactoring, hooks api has changed + * Dozens of bug fixes + +---- + +### 1.1.6.2 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) May 2007 + + * Released with GHC 6.6.1 + * Handle windows text file encoding for `.cabal` files + * Fix compiling a executable for profiling that uses Template Haskell + * Other minor bug fixes and user guide clarifications + +### 1.1.6.1 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) Oct 2006 + + * fix unlit code + * fix escaping in register.sh + +## 1.1.6 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) Oct 2006 + + * Released with GHC 6.6 + * Added support for hoogle + * Allow profiling and normal builds of libs to be chosen independently + * Default installation directories on Win32 changed + * Register haddock docs with ghc-pkg + * Get haddock to make hyperlinks to dependent package docs + * Added BangPatterns language extension + * Various bug fixes + +## 1.1.4 [Duncan Coutts](mailto:duncan.coutts@worc.ox.ac.uk) May 2006 + + * Released with GHC 6.4.2 + * Better support for packages that need to install header files + * cabal-setup added, but not installed by default yet + * Implemented `setup register --inplace` + * Have packages exposed by default with ghc-6.2 + * It is no longer necessary to run `configure` before `clean` or `sdist` + * Added support for ghc's `-split-objs` + * Initial support for JHC + * Ignore extension fields in `.cabal` files (fields beginning with "`x-`") + * Some changes to command hooks API to improve consistency + * Hugs support improvements + * Added GeneralisedNewtypeDeriving language extension + * Added cabal-version field + * Support hidden modules with haddock + * Internal code refactoring + * More bug fixes + +## 1.1.3 [Isaac Jones](mailto:ijones@syntaxpolice.org) Sept 2005 + + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Move building of GHCi .o libs to the build phase rather than + register phase. (from Duncan Coutts) + * Use .tar.gz for source package extension + * Uses GHC instead of cpphs if the latter is not available + * Added experimental "command hooks" which completely override the + default behavior of a command. + * Some bugfixes + +# 1.1.1 [Isaac Jones](mailto:ijones@syntaxpolice.org) July 2005 + + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Handles recursive modules for GHC 6.2 and GHC 6.4. + * Added `setup test` command (Used with UserHook) + * implemented handling of _stub.{c,h,o} files + * Added support for profiling + * Changed install prefix of libraries (pref/pkgname-version + to prefix/pkgname-version/compname-version) + * Added pattern guards as a language extension + * Moved some functionality to Language.Haskell.Extension + * Register / unregister .bat files for windows + * Exposed more of the API + * Added support for the hide-all-packages flag in GHC > 6.4 + * Several bug fixes + +---- + +# 1.0 [Isaac Jones](mailto:ijones@syntaxpolice.org) March 11 2005 + + * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 + * Some sanity checking + +---- + +# 0.5 [Isaac Jones](mailto:ijones@syntaxpolice.org) Wed Feb 19 2005 + + * __WARNING__: this is a pre-release and the interfaces are + still likely to change until we reach a 1.0 release. + * Hooks interfaces changed + * Added preprocessors to user hooks + * No more executable-modules or hidden-modules. Use + `other-modules` instead. + * Certain fields moved into BuildInfo, much refactoring + * `extra-libs` -> `extra-libraries` + * Added `--gen-script` to configure and unconfigure. + * `modules-ghc` (etc) now `ghc-modules` (etc) + * added new fields including `synopsis` + * Lots of bug fixes + * spaces can sometimes be used instead of commas + * A user manual has appeared (Thanks, ross!) + * for ghc 6.4, configures versioned depends properly + * more features to `./setup haddock` + +---- + +# 0.4 [Isaac Jones](mailto:ijones@syntaxpolice.org) Sun Jan 16 2005 + + * Much thanks to all the awesome fptools hackers who have been + working hard to build the Haskell Cabal! + + * __Interface Changes__: + + * __WARNING__: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + + * Instead of Package.description, you should name your + description files .cabal. In particular, we suggest + that you name it .cabal, but this is not enforced + (yet). Multiple `.cabal` files in the same directory is an error, + at least for now. + + * `./setup install --install-prefix` is gone. Use `./setup copy` + `--copy-prefix` instead. + + * The `Modules` field is gone. Use `hidden-modules`, + `exposed-modules`, and `executable-modules`. + + * `Build-depends` is now a package-only field, and can't go into + executable stanzas. Build-depends is a package-to-package + relationship. + + * Some new fields. Use the Source. + + * __New Features__ + + * Cabal is now included as a package in the CVS version of + fptools. That means it'll be released as `-package Cabal` in + future versions of the compilers, and if you are a bleeding-edge + user, you can grab it from the CVS repository with the compilers. + + * Hugs compatibility and NHC98 compatibility should both be + improved. + + * Hooks Interface / Autoconf compatibility: Most of the hooks + interface is hidden for now, because it's not finalized. I have + exposed only `defaultMainWithHooks` and `defaultUserHooks`. This + allows you to use a ./configure script to preprocess + `foo.buildinfo`, which gets merged with `foo.cabal`. In future + releases, we'll expose UserHooks, but we're definitely going to + change the interface to those. The interface to the two functions + I've exposed should stay the same, though. + + * ./setup haddock is a baby feature which pre-processes the + source code with hscpp and runs haddock on it. This is brand new + and hardly tested, so you get to knock it around and see what you + think. + + * Some commands now actually implement verbosity. + + * The preprocessors have been tested a bit more, and seem to work + OK. Please give feedback if you use these. + +---- + +# 0.3 [Isaac Jones](mailto:ijones@syntaxpolice.org) Sun Jan 16 2005 + + * Unstable snapshot release + * From now on, stable releases are even. + +---- + +# 0.2 [Isaac Jones](mailto:ijones@syntaxpolice.org) + + * Adds more HUGS support and preprocessor support. diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs deleted file mode 100644 --- a/Distribution/Compat/ReadP.hs +++ /dev/null @@ -1,483 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.ReadP --- Copyright : (c) The University of Glasgow 2002 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This is a library of parser combinators, originally written by Koen Claessen. --- It parses all alternatives in parallel, so it never keeps hold of --- the beginning of the input string, a common source of space leaks with --- other parsers. The '(+++)' choice combinator is genuinely commutative; --- it makes no difference which branch is \"shorter\". --- --- See also Koen's paper /Parallel Parsing Processes/ --- (). --- --- This version of ReadP has been locally hacked to make it H98, by --- Martin Sjögren --- ------------------------------------------------------------------------------ - -module Distribution.Compat.ReadP - ( - -- * The 'ReadP' type - ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus - - -- * Primitive operations - get, -- :: ReadP Char - look, -- :: ReadP String - (+++), -- :: ReadP a -> ReadP a -> ReadP a - (<++), -- :: ReadP a -> ReadP a -> ReadP a - gather, -- :: ReadP a -> ReadP (String, a) - - -- * Other operations - pfail, -- :: ReadP a - satisfy, -- :: (Char -> Bool) -> ReadP Char - char, -- :: Char -> ReadP Char - string, -- :: String -> ReadP String - munch, -- :: (Char -> Bool) -> ReadP String - munch1, -- :: (Char -> Bool) -> ReadP String - skipSpaces, -- :: ReadP () - choice, -- :: [ReadP a] -> ReadP a - count, -- :: Int -> ReadP a -> ReadP [a] - between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a - option, -- :: a -> ReadP a -> ReadP a - optional, -- :: ReadP a -> ReadP () - many, -- :: ReadP a -> ReadP [a] - many1, -- :: ReadP a -> ReadP [a] - skipMany, -- :: ReadP a -> ReadP () - skipMany1, -- :: ReadP a -> ReadP () - sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] - - -- * Running a parser - ReadS, -- :: *; = String -> [(a,String)] - readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P -- :: ReadS a -> ReadP a - -#if __GLASGOW_HASKELL__ < 603 && !__HUGS__ - -- * Properties - -- $properties -#endif - ) - where - -#if __GLASGOW_HASKELL__ >= 603 || __HUGS__ - -import Text.ParserCombinators.ReadP hiding (ReadP) -import qualified Text.ParserCombinators.ReadP as ReadP - -type ReadP r a = ReadP.ReadP a - -#else - -import Control.Monad( MonadPlus(..), liftM2 ) -import Data.Char (isSpace) - -infixr 5 +++, <++ - --- --------------------------------------------------------------------------- --- The P type --- is representation type -- should be kept abstract - -data P s a - = Get (s -> P s a) - | Look ([s] -> P s a) - | Fail - | Result a (P s a) - | Final [(a,[s])] -- invariant: list is non-empty! - --- Monad, MonadPlus - -instance Monad (P s) where - return x = Result x Fail - - (Get f) >>= k = Get (\c -> f c >>= k) - (Look f) >>= k = Look (\s -> f s >>= k) - Fail >>= _ = Fail - (Result x p) >>= k = k x `mplus` (p >>= k) - (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] - - fail _ = Fail - -instance MonadPlus (P s) where - mzero = Fail - - -- most common case: two gets are combined - Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) - - -- results are delivered as soon as possible - Result x p `mplus` q = Result x (p `mplus` q) - p `mplus` Result x q = Result x (p `mplus` q) - - -- fail disappears - Fail `mplus` p = p - p `mplus` Fail = p - - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - Final r `mplus` Final t = Final (r ++ t) - Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) - Final r `mplus` p = Look (\s -> Final (r ++ run p s)) - Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) - p `mplus` Final r = Look (\s -> Final (run p s ++ r)) - - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - Look f `mplus` Look g = Look (\s -> f s `mplus` g s) - Look f `mplus` p = Look (\s -> f s `mplus` p) - p `mplus` Look f = Look (\s -> p `mplus` f s) - --- --------------------------------------------------------------------------- --- The ReadP type - -newtype Parser r s a = R ((a -> P s r) -> P s r) -type ReadP r a = Parser r Char a - --- Functor, Monad, MonadPlus - -instance Functor (Parser r s) where - fmap h (R f) = R (\k -> f (k . h)) - -instance Monad (Parser r s) where - return x = R (\k -> k x) - fail _ = R (\_ -> Fail) - R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) - ---instance MonadPlus (Parser r s) where --- mzero = pfail --- mplus = (+++) - --- --------------------------------------------------------------------------- --- Operations over P - -final :: [(a,[s])] -> P s a --- Maintains invariant for Final constructor -final [] = Fail -final r = Final r - -run :: P c a -> ([c] -> [(a, [c])]) -run (Get f) (c:s) = run (f c) s -run (Look f) s = run (f s) s -run (Result x p) s = (x,s) : run p s -run (Final r) _ = r -run _ _ = [] - --- --------------------------------------------------------------------------- --- Operations over ReadP - -get :: ReadP r Char --- ^ Consumes and returns the next character. --- Fails if there is no input left. -get = R Get - -look :: ReadP r String --- ^ Look-ahead: returns the part of the input that is left, without --- consuming it. -look = R Look - -pfail :: ReadP r a --- ^ Always fails. -pfail = R (\_ -> Fail) - -(+++) :: ReadP r a -> ReadP r a -> ReadP r a --- ^ Symmetric choice. -R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) - -(<++) :: ReadP a a -> ReadP r a -> ReadP r a --- ^ Local, exclusive, left-biased choice: If left parser --- locally produces any result at all, then right parser is --- not used. -R f <++ q = - do s <- look - probe (f return) s 0 - where - probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) - probe (Look f') s n = probe (f' s) s n - probe p@(Result _ _) _ n = discard n >> R (p >>=) - probe (Final r) _ _ = R (Final r >>=) - probe _ _ _ = q - - discard 0 = return () - discard n = get >> discard (n-1 :: Int) - -gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) --- ^ Transforms a parser into one that does the same, but --- in addition returns the exact characters read. --- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument --- is built using any occurrences of readS_to_P. -gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) - where - gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) - gath _ Fail = Fail - gath l (Look f) = Look (\s -> gath l (f s)) - gath l (Result k p) = k (l []) `mplus` gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" - --- --------------------------------------------------------------------------- --- Derived operations - -satisfy :: (Char -> Bool) -> ReadP r Char --- ^ Consumes and returns the next character, if it satisfies the --- specified predicate. -satisfy p = do c <- get; if p c then return c else pfail - -char :: Char -> ReadP r Char --- ^ Parses and returns the specified character. -char c = satisfy (c ==) - -string :: String -> ReadP r String --- ^ Parses and returns the specified string. -string this = do s <- look; scan this s - where - scan [] _ = do return this - scan (x:xs) (y:ys) | x == y = do get; scan xs ys - scan _ _ = do pfail - -munch :: (Char -> Bool) -> ReadP r String --- ^ Parses the first zero or more characters satisfying the predicate. -munch p = - do s <- look - scan s - where - scan (c:cs) | p c = do get; s <- scan cs; return (c:s) - scan _ = do return "" - -munch1 :: (Char -> Bool) -> ReadP r String --- ^ Parses the first one or more characters satisfying the predicate. -munch1 p = - do c <- get - if p c then do s <- munch p; return (c:s) else pfail - -choice :: [ReadP r a] -> ReadP r a --- ^ Combines all parsers in the specified list. -choice [] = pfail -choice [p] = p -choice (p:ps) = p +++ choice ps - -skipSpaces :: ReadP r () --- ^ Skips all whitespace. -skipSpaces = - do s <- look - skip s - where - skip (c:s) | isSpace c = do get; skip s - skip _ = do return () - -count :: Int -> ReadP r a -> ReadP r [a] --- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of --- results is returned. -count n p = sequence (replicate n p) - -between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a --- ^ @ between open close p @ parses @open@, followed by @p@ and finally --- @close@. Only the value of @p@ is returned. -between open close p = do open - x <- p - close - return x - -option :: a -> ReadP r a -> ReadP r a --- ^ @option x p@ will either parse @p@ or return @x@ without consuming --- any input. -option x p = p +++ return x - -optional :: ReadP r a -> ReadP r () --- ^ @optional p@ optionally parses @p@ and always returns @()@. -optional p = (p >> return ()) +++ return () - -many :: ReadP r a -> ReadP r [a] --- ^ Parses zero or more occurrences of the given parser. -many p = return [] +++ many1 p - -many1 :: ReadP r a -> ReadP r [a] --- ^ Parses one or more occurrences of the given parser. -many1 p = liftM2 (:) p (many p) - -skipMany :: ReadP r a -> ReadP r () --- ^ Like 'many', but discards the result. -skipMany p = many p >> return () - -skipMany1 :: ReadP r a -> ReadP r () --- ^ Like 'many1', but discards the result. -skipMany1 p = p >> skipMany p - -sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy p sep = sepBy1 p sep +++ return [] - -sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy1 p sep = liftM2 (:) p (many (sep >> p)) - -endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended --- by @sep@. -endBy p sep = many (do x <- p ; sep ; return x) - -endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended --- by @sep@. -endBy1 p sep = many1 (do x <- p ; sep ; return x) - -chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /right/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainr p op x = chainr1 p op +++ return x - -chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /left/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainl p op x = chainl1 p op +++ return x - -chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainr', but parses one or more occurrences of @p@. -chainr1 p op = scan - where scan = p >>= rest - rest x = do f <- op - y <- scan - return (f x y) - +++ return x - -chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainl', but parses one or more occurrences of @p@. -chainl1 p op = p >>= rest - where rest x = do f <- op - y <- p - rest (f x y) - +++ return x - -manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] --- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ --- succeeds. Returns a list of values returned by @p@. -manyTill p end = scan - where scan = (end >> return []) <++ (liftM2 (:) p scan) - --- --------------------------------------------------------------------------- --- Converting between ReadP and Read - -readP_to_S :: ReadP a a -> ReadS a --- ^ Converts a parser into a Haskell ReadS-style function. --- This is the main way in which you can \"run\" a 'ReadP' parser: --- the expanded type is --- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ -readP_to_S (R f) = run (f return) - -readS_to_P :: ReadS a -> ReadP r a --- ^ Converts a Haskell ReadS-style function into a parser. --- Warning: This introduces local backtracking in the resulting --- parser, and therefore a possible inefficiency. -readS_to_P r = - R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) - --- --------------------------------------------------------------------------- --- QuickCheck properties that hold for the combinators - -{- $properties -The following are QuickCheck specifications of what the combinators do. -These can be seen as formal specifications of the behavior of the -combinators. - -We use bags to give semantics to the combinators. - -> type Bag a = [a] - -Equality on bags does not care about the order of elements. - -> (=~) :: Ord a => Bag a -> Bag a -> Bool -> xs =~ ys = sort xs == sort ys - -A special equality operator to avoid unresolved overloading -when testing the properties. - -> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool -> (=~.) = (=~) - -Here follow the properties: - -> prop_Get_Nil = -> readP_to_S get [] =~ [] -> -> prop_Get_Cons c s = -> readP_to_S get (c:s) =~ [(c,s)] -> -> prop_Look s = -> readP_to_S look s =~ [(s,s)] -> -> prop_Fail s = -> readP_to_S pfail s =~. [] -> -> prop_Return x s = -> readP_to_S (return x) s =~. [(x,s)] -> -> prop_Bind p k s = -> readP_to_S (p >>= k) s =~. -> [ ys'' -> | (x,s') <- readP_to_S p s -> , ys'' <- readP_to_S (k (x::Int)) s' -> ] -> -> prop_Plus p q s = -> readP_to_S (p +++ q) s =~. -> (readP_to_S p s ++ readP_to_S q s) -> -> prop_LeftPlus p q s = -> readP_to_S (p <++ q) s =~. -> (readP_to_S p s +<+ readP_to_S q s) -> where -> [] +<+ ys = ys -> xs +<+ _ = xs -> -> prop_Gather s = -> forAll readPWithoutReadS $ \p -> -> readP_to_S (gather p) s =~ -> [ ((pre,x::Int),s') -> | (x,s') <- readP_to_S p s -> , let pre = take (length s - length s') s -> ] -> -> prop_String_Yes this s = -> readP_to_S (string this) (this ++ s) =~ -> [(this,s)] -> -> prop_String_Maybe this s = -> readP_to_S (string this) s =~ -> [(this, drop (length this) s) | this `isPrefixOf` s] -> -> prop_Munch p s = -> readP_to_S (munch p) s =~ -> [(takeWhile p s, dropWhile p s)] -> -> prop_Munch1 p s = -> readP_to_S (munch1 p) s =~ -> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] -> -> prop_Choice ps s = -> readP_to_S (choice ps) s =~. -> readP_to_S (foldr (+++) pfail ps) s -> -> prop_ReadS r s = -> readP_to_S (readS_to_P r) s =~. r s --} - -#endif diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs deleted file mode 100644 --- a/Distribution/Compat/TempFile.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) where - -#if __NHC__ || __HUGS__ -import System.IO (openFile, openBinaryFile, - Handle, IOMode(ReadWriteMode)) -import System.Directory (doesFileExist) -import System.FilePath ((), (<.>), splitExtension) -#if __NHC__ -import System.Posix.Types (CPid(..)) -foreign import ccall unsafe "getpid" c_getpid :: IO CPid -#else -import System.Posix.Internals (c_getpid) -#endif -#else -import System.IO (openTempFile, openBinaryTempFile) -#endif - --- ------------------------------------------------------------ --- * temporary files --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: Not sure about jhc - -#if __NHC__ || __HUGS__ --- use a temporary filename that doesn't already exist. --- NB. *not* secure (we don't atomically lock the tmp file we get) -openTempFile :: FilePath -> String -> IO (FilePath, Handle) -openTempFile tmp_dir template - = do x <- getProcessID - findTempName x - where - (templateBase, templateExt) = splitExtension template - findTempName :: Int -> IO (FilePath, Handle) - findTempName x - = do let path = tmp_dir (templateBase ++ show x) <.> templateExt - b <- doesFileExist path - if b then findTempName (x+1) - else do hnd <- openFile path ReadWriteMode - return (path, hnd) - -openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template - = do x <- getProcessID - findTempName x - where - (templateBase, templateExt) = splitExtension template - findTempName :: Int -> IO (FilePath, Handle) - findTempName x - = do let path = tmp_dir (templateBase ++ show x) <.> templateExt - b <- doesFileExist path - if b then findTempName (x+1) - else do hnd <- openBinaryFile path ReadWriteMode - return (path, hnd) - -getProcessID :: IO Int -getProcessID = fmap fromIntegral c_getpid -#endif diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs deleted file mode 100644 --- a/Distribution/Compiler.hs +++ /dev/null @@ -1,146 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compiler --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Haskell compiler flavors - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Compiler ( - -- * Compiler flavor - CompilerFlavor(..), - buildCompilerFlavor, - defaultCompilerFlavor, - parseCompilerFlavorCompat, - - -- * Compiler id - CompilerId(..), - ) where - -import Distribution.Version (Version(..)) - -import qualified System.Info (compilerName) -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) - -import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) -import Control.Monad (when) - -data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC - | OtherCompiler String - deriving (Show, Read, Eq, Ord) - -knownCompilerFlavors :: [CompilerFlavor] -knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC] - -instance Text CompilerFlavor where - disp (OtherCompiler name) = Disp.text name - disp NHC = Disp.text "nhc98" - disp other = Disp.text (lowercase (show other)) - - parse = do - comp <- Parse.munch1 Char.isAlphaNum - when (all Char.isDigit comp) Parse.pfail - return (classifyCompilerFlavor comp) - -classifyCompilerFlavor :: String -> CompilerFlavor -classifyCompilerFlavor s = - case lookup (lowercase s) compilerMap of - Just compiler -> compiler - Nothing -> OtherCompiler s - where - compilerMap = [ (display compiler, compiler) - | compiler <- knownCompilerFlavors ] - - ---TODO: In some future release, remove 'parseCompilerFlavorCompat' and use --- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. - --- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. --- --- It is compatible in the sense that it accepts only the same strings, --- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. --- The point of this is that we do not allow extra valid values that would --- upset older Cabal versions that had a stricter parser however we cope with --- new values more gracefully so that we'll be able to introduce new value in --- future without breaking things so much. --- -parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor -parseCompilerFlavorCompat = do - comp <- Parse.munch1 Char.isAlphaNum - when (all Char.isDigit comp) Parse.pfail - case lookup comp compilerMap of - Just compiler -> return compiler - Nothing -> return (OtherCompiler comp) - where - compilerMap = [ (show compiler, compiler) - | compiler <- knownCompilerFlavors - , compiler /= YHC ] - -buildCompilerFlavor :: CompilerFlavor -buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName - --- | The default compiler flavour to pick when compiling stuff. This defaults --- to the compiler used to build the Cabal lib. --- --- However if it's not a recognised compiler then it's 'Nothing' and the user --- will have to specify which compiler they want. --- -defaultCompilerFlavor :: Maybe CompilerFlavor -defaultCompilerFlavor = case buildCompilerFlavor of - OtherCompiler _ -> Nothing - _ -> Just buildCompilerFlavor - --- ------------------------------------------------------------ --- * Compiler Id --- ------------------------------------------------------------ - -data CompilerId = CompilerId CompilerFlavor Version - deriving (Eq, Ord, Read, Show) - -instance Text CompilerId where - disp (CompilerId f (Version [] _)) = disp f - disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v - - parse = do - flavour <- parse - version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) - return (CompilerId flavour version) - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/Distribution/Extension.hs b/Distribution/Extension.hs deleted file mode 100644 --- a/Distribution/Extension.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Extension --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Haskell language extensions - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Extension -{-# DEPRECATED "Use modules Language.Haskell.Extension and Distribution.Compiler instead" #-} - (Extension(..) - ) where - -import Language.Haskell.Extension (Extension(..)) diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs deleted file mode 100644 --- a/Distribution/GetOpt.hs +++ /dev/null @@ -1,336 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.GetOpt --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- This library provides facilities for parsing the command-line options --- in a standalone program. It is essentially a Haskell port of the GNU --- @getopt@ library. --- ------------------------------------------------------------------------------ - -{- -Sven Panne Oct. 1996 (small -changes Dec. 1997) - -Two rather obscure features are missing: The Bash 2.0 non-option hack -(if you don't already know it, you probably don't want to hear about -it...) and the recognition of long options with a single dash -(e.g. '-help' is recognised as '--help', as long as there is no short -option 'h'). - -Other differences between GNU's getopt and this implementation: - -* To enforce a coherent description of options and arguments, there - are explanation fields in the option/argument descriptor. - -* Error messages are now more informative, but no longer POSIX - compliant... :-( - -And a final Haskell advertisement: The GNU C implementation uses well -over 1100 lines, we need only 195 here, including a 46 line example! -:-) --} - --- #hide -module Distribution.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), - - -- * Example - - -- $example -) where - -import Data.List ( isPrefixOf, intersperse, find ) - --- |What to do with options following non-options -data ArgOrder a - = RequireOrder -- ^ no option processing after first non-option - | Permute -- ^ freely intersperse options and non-options - | ReturnInOrder (String -> a) -- ^ wrap non-options into options - -{-| -Each 'OptDescr' describes a single option. - -The arguments to 'Option' are: - -* list of short option characters - -* list of long option strings (without \"--\") - -* argument descriptor - -* explanation of option for user --} -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user - --- |Describes whether an option takes an argument or not, and if so --- how the argument is injected into a value of type @a@. -data ArgDescr a - = NoArg a -- ^ no argument expected - | ReqArg (String -> a) String -- ^ option requires argument - | OptArg (Maybe String -> a) String -- ^ optional argument - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - --- | Return a string describing the usage of a command, derived from --- the header (first argument) and the options described by the --- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos) - ,sepBy ", " (map (fmtLong ad) los) - ,d) - | Option sos los ad d <- optDescr ] - ssWidth = (maximum . map length) ss - lsWidth = (maximum . map length) ls - dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) - table = [ " " ++ padTo ssWidth so' ++ - " " ++ padTo lsWidth lo' ++ - " " ++ d' - | (so,lo,d) <- zip3 ss ls ds - , (so',lo',d') <- fmtOpt dsWidth so lo d ] - padTo n x = take n (x ++ repeat ' ') - sepBy s = concat . intersperse s - -fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] -fmtOpt descrWidth so lo descr = - case wrapText descrWidth descr of - [] -> [(so,lo,"")] - (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] - -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ _) so = "-" ++ [so] -fmtShort (OptArg _ _) so = "-" ++ [so] - -fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" - -wrapText :: Int -> String -> [String] -wrapText width = map unwords . wrap 0 [] . words - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). - -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args - -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest - --- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) - --- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - getWith p = [ o | o@(Option _ xs _ _) <- optDescr - , find (p opt) xs /= Nothing] - exact = getWith (==) - options = if null exact then getWith isPrefixOf else exact - ads = [ ad | Option _ _ ad _ <- options ] - optStr = ("--"++opt) - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) - --- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -shortOpt y ys rs optDescr = short ads ys rs - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[y] - - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) - short (ReqArg f _:_) xs rest = (Opt (f xs),rest) - short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) - short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) - short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt optStr,('-':xs):rest) - --- miscellaneous error formatting - -errAmbig :: [OptDescr a] -> String -> OptKind a -errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" - -errReq :: String -> String -> OptKind a -errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") - -errUnrec :: String -> String -errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" - -errNoArg :: String -> OptKind a -errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") - -{- ------------------------------------------------------------------------------------------ --- and here a small and hopefully enlightening example: - -data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show - -options :: [OptDescr Flag] -options = - [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", - Option ['V','?'] ["version","release"] (NoArg Version) "show version info", - Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", - Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] - -out :: Maybe String -> Flag -out Nothing = Output "stdout" -out (Just o) = Output o - -test :: ArgOrder Flag -> [String] -> String -test order cmdline = case getOpt order options cmdline of - (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" - (_,_,errs) -> concat errs ++ usageInfo header options - where header = "Usage: foobar [OPTION...] files..." - --- example runs: --- putStr (test RequireOrder ["foo","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["foo","-v"]) --- ==> options=[Verbose] args=["foo"] --- putStr (test (ReturnInOrder Arg) ["foo","-v"]) --- ==> options=[Arg "foo", Verbose] args=[] --- putStr (test Permute ["foo","--","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["-?o","--name","bar","--na=baz"]) --- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] --- putStr (test Permute ["--ver","foo"]) --- ==> option `--ver' is ambiguous; could be one of: --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- Usage: foobar [OPTION...] files... --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- -o[FILE] --output[=FILE] use FILE for dump --- -n USER --name=USER only dump USER's files ------------------------------------------------------------------------------------------ --} - -{- $example - -To hopefully illuminate the role of the different data -structures, here\'s the command-line options for a (very simple) -compiler: - -> module Opts where -> -> import Distribution.GetOpt -> import Data.Maybe ( fromMaybe ) -> -> data Flag -> = Verbose | Version -> | Input String | Output String | LibDir String -> deriving Show -> -> options :: [OptDescr Flag] -> options = -> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" -> , Option ['V','?'] ["version"] (NoArg Version) "show version number" -> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" -> , Option ['c'] [] (OptArg inp "FILE") "input FILE" -> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" -> ] -> -> inp,outp :: Maybe String -> Flag -> outp = Output . fromMaybe "stdout" -> inp = Input . fromMaybe "stdin" -> -> compilerOpts :: [String] -> IO ([Flag], [String]) -> compilerOpts argv = -> case getOpt Permute options argv of -> (o,n,[] ) -> return (o,n) -> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) -> where header = "Usage: ic [OPTION...] files..." - --} diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs deleted file mode 100644 --- a/Distribution/InstalledPackageInfo.hs +++ /dev/null @@ -1,297 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.InstalledPackageInfo --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Stability : alpha --- Portability : portable --- --- This is the information about an /installed/ package that --- is communicated to the @hc-pkg@ program in order to register --- a package. @ghc-pkg@ now consumes this package format (as of verison --- 6.4). This is specific to GHC at the moment. - - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of the University nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- This module is meant to be local-only to Distribution... - -module Distribution.InstalledPackageInfo ( - InstalledPackageInfo_(..), InstalledPackageInfo, - ParseResult(..), PError(..), PWarning, - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showInstalledPackageInfoField, - ) where - -import Distribution.ParseUtils ( - FieldDescr(..), readFields, ParseResult(..), PError(..), PWarning, - Field(F), simpleField, listField, parseLicenseQ, ppField, ppFields, - parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ, - showFilePath, showToken, boolField, parseOptVersion, parseQuoted, - showFreeText) -import Distribution.License ( License(..) ) -import Distribution.Package - ( PackageIdentifier(..), packageName, packageVersion ) -import qualified Distribution.Package as Package - ( Package(..), PackageFixedDeps(..) ) -import Distribution.Version - ( Version(..) ) -import Distribution.Text - ( Text(disp, parse) ) -import qualified Distribution.Compat.ReadP as ReadP - -import Control.Monad ( foldM ) -import Text.PrettyPrint - --- ----------------------------------------------------------------------------- --- The InstalledPackageInfo type - -data InstalledPackageInfo_ m - = InstalledPackageInfo { - -- these parts are exactly the same as PackageDescription - package :: PackageIdentifier, - license :: License, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - homepage :: String, - pkgUrl :: String, - description :: String, - category :: String, - -- these parts are required by an installed package only: - exposed :: Bool, - exposedModules :: [m], - hiddenModules :: [m], - importDirs :: [FilePath], -- contain sources in case of Hugs - libraryDirs :: [FilePath], - hsLibraries :: [String], - extraLibraries :: [String], - extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi - includeDirs :: [FilePath], - includes :: [String], - depends :: [PackageIdentifier], - hugsOptions :: [String], - ccOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath] - } - deriving (Read, Show) - -instance Package.Package (InstalledPackageInfo_ str) where - packageId = package -instance Package.PackageFixedDeps (InstalledPackageInfo_ str) where - depends = depends - -type InstalledPackageInfo = InstalledPackageInfo_ String - -emptyInstalledPackageInfo :: InstalledPackageInfo_ m -emptyInstalledPackageInfo - = InstalledPackageInfo { - package = PackageIdentifier "" noVersion, - license = AllRightsReserved, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - description = "", - category = "", - exposed = False, - exposedModules = [], - hiddenModules = [], - importDirs = [], - libraryDirs = [], - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries= [], - includeDirs = [], - includes = [], - depends = [], - hugsOptions = [], - ccOptions = [], - ldOptions = [], - frameworkDirs = [], - frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [] - } - -noVersion :: Version -noVersion = Version{ versionBranch=[], versionTags=[] } - --- ----------------------------------------------------------------------------- --- Parsing - -parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo -parseInstalledPackageInfo inp = do - stLines <- readFields inp - -- not interested in stanzas, so just allow blank lines in - -- the package info. - foldM (parseBasicStanza all_fields) emptyInstalledPackageInfo stLines - -parseBasicStanza :: [FieldDescr a] - -> a - -> Field - -> ParseResult a -parseBasicStanza ((FieldDescr name _ set):fields) pkg (F lineNo f val) - | name == f = set lineNo val pkg - | otherwise = parseBasicStanza fields pkg (F lineNo f val) -parseBasicStanza [] pkg _ = return pkg -parseBasicStanza _ _ _ = - error "parseBasicStanza must be called with a simple field." - --- ----------------------------------------------------------------------------- --- Pretty-printing - -showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo pkg = render (ppFields pkg all_fields) - -showInstalledPackageInfoField - :: String - -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField field - = case [ (f,get') | (FieldDescr f get' _) <- all_fields, f == field ] of - [] -> Nothing - ((f,get'):_) -> Just (render . ppField f . get') - --- ----------------------------------------------------------------------------- --- Description of the fields, for parsing/printing - -all_fields :: [FieldDescr InstalledPackageInfo] -all_fields = basicFieldDescrs ++ installedFieldDescrs - -basicFieldDescrs :: [FieldDescr InstalledPackageInfo] -basicFieldDescrs = - [ simpleField "name" - text parsePackageNameQ - packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) - , simpleField "version" - disp parseOptVersion - packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) - , simpleField "license" - disp parseLicenseQ - license (\l pkg -> pkg{license=l}) - , simpleField "copyright" - showFreeText parseFreeText - copyright (\val pkg -> pkg{copyright=val}) - , simpleField "maintainer" - showFreeText parseFreeText - maintainer (\val pkg -> pkg{maintainer=val}) - , simpleField "stability" - showFreeText parseFreeText - stability (\val pkg -> pkg{stability=val}) - , simpleField "homepage" - showFreeText parseFreeText - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText parseFreeText - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "description" - showFreeText parseFreeText - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText parseFreeText - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText parseFreeText - author (\val pkg -> pkg{author=val}) - ] - -parseFreeText :: ReadP.ReadP s String -parseFreeText = ReadP.munch (const True) - -installedFieldDescrs :: [FieldDescr InstalledPackageInfo] -installedFieldDescrs = [ - boolField "exposed" - exposed (\val pkg -> pkg{exposed=val}) - , listField "exposed-modules" - text parseModuleNameQ - exposedModules (\xs pkg -> pkg{exposedModules=xs}) - , listField "hidden-modules" - text parseModuleNameQ - hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) - , listField "import-dirs" - showFilePath parseFilePathQ - importDirs (\xs pkg -> pkg{importDirs=xs}) - , listField "library-dirs" - showFilePath parseFilePathQ - libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) - , listField "hs-libraries" - showFilePath parseTokenQ - hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) - , listField "extra-libraries" - showToken parseTokenQ - extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) - , listField "extra-ghci-libraries" - showToken parseTokenQ - extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) - , listField "include-dirs" - showFilePath parseFilePathQ - includeDirs (\xs pkg -> pkg{includeDirs=xs}) - , listField "includes" - showFilePath parseFilePathQ - includes (\xs pkg -> pkg{includes=xs}) - , listField "depends" - disp parsePackageId' - depends (\xs pkg -> pkg{depends=xs}) - , listField "hugs-options" - showToken parseTokenQ - hugsOptions (\path pkg -> pkg{hugsOptions=path}) - , listField "cc-options" - showToken parseTokenQ - ccOptions (\path pkg -> pkg{ccOptions=path}) - , listField "ld-options" - showToken parseTokenQ - ldOptions (\path pkg -> pkg{ldOptions=path}) - , listField "framework-dirs" - showFilePath parseFilePathQ - frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) - , listField "frameworks" - showToken parseTokenQ - frameworks (\xs pkg -> pkg{frameworks=xs}) - , listField "haddock-interfaces" - showFilePath parseFilePathQ - haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) - , listField "haddock-html" - showFilePath parseFilePathQ - haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) - ] - -parsePackageId' :: ReadP.ReadP [PackageIdentifier] PackageIdentifier -parsePackageId' = parseQuoted parse ReadP.<++ parse diff --git a/Distribution/License.hs b/Distribution/License.hs deleted file mode 100644 --- a/Distribution/License.hs +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.License --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- The License datatype. For more information about these and other --- open-source licenses, you may visit . --- --- I am not a lawyer, but as a general guideline, most Haskell --- software seems to be released under a BSD3 license, which is very --- open and free. If you don't want to restrict the use of your --- software or its source code, use BSD3 or PublicDomain. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.License ( - License(..) - ) where - -import Distribution.Version (Version) - -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import qualified Data.Char as Char (isAlphaNum) - --- |This datatype indicates the license under which your package is --- released. It is also wise to add your license to each source file --- using the license-file field. The 'AllRightsReserved' constructor --- is not actually a license, but states that you are not giving --- anyone else a license to use or distribute your work. The comments --- below are general guidelines. Please read the licenses themselves --- and consult a lawyer if you are unsure of your rights to release --- the software. --- -data License = - ---TODO: * deprecate BSD4 --- * add optional gpl versions --- * add MIT license - - -- | GNU Public License. Source code must accompany alterations. - GPL --(Maybe Version) - - -- | Lesser GPL, Less restrictive than GPL, useful for libraries. - | LGPL --(Maybe Version) - - -- | 3-clause BSD license, newer, no advertising clause. Very free license. - | BSD3 - - -- | 4-clause BSD license, older, with advertising clause. - | BSD4 - --- -- | The MIT license, similar to the BSD3. Very free license. --- | MIT - - -- | Holder makes no claim to ownership, least restrictive license. - | PublicDomain - - -- | No rights are granted to others. Undistributable. Most restrictive. - | AllRightsReserved - - -- | Some other license. - | OtherLicense - - -- | Not a recognised license. - -- Allows us to deal with future extensions more gracefully. - | UnknownLicense String - deriving (Read, Show, Eq) - ---TODO: use knownLicenses to give a better parse error message ---knownLicenses :: [License] ---knownLicenses = [GPL Nothing, LGPL Nothing, BSD3, BSD4, MIT --- ,PublicDomain, AllRightsReserved, OtherLicense] - -instance Text License where ---disp (GPL version) = "GPL" <> showOptionalVersion version ---disp (LGPL version) = "LGPL" <> showOptionalVersion version - disp (UnknownLicense other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - name <- Parse.munch1 Char.isAlphaNum - version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) - -- We parse an optional version but do not yet allow it on any known - -- license. However parsing the version will allow forwards compatability - -- for when we do introduce optional (L)GPL license versions. - return $ case (name, version :: Maybe Version) of - ("GPL", Nothing) -> GPL - ("LGPL", Nothing) -> LGPL - -- ("GPL", version) -> GPL version - -- ("LGPL", version) -> LGPL version - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - -- ("MIT", Nothing) -> MIT - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name - ++ maybe "" (('-':) . display) version diff --git a/Distribution/Make.hs b/Distribution/Make.hs deleted file mode 100644 --- a/Distribution/Make.hs +++ /dev/null @@ -1,206 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Make --- Copyright : Martin Sjögren 2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Uses the parsed command-line from Distribution.Setup in order to build --- Haskell tools using a backend build system based on make. Obviously we --- assume that there is a configure script, and that after the ConfigCmd has --- been run, there is a Makefile. Further assumptions: --- --- [ConfigCmd] We assume the configure script accepts --- @--with-hc@, --- @--with-hc-pkg@, --- @--prefix@, --- @--bindir@, --- @--libdir@, --- @--libexecdir@, --- @--datadir@. --- --- [BuildCmd] We assume that the default Makefile target will build everything. --- --- [InstallCmd] We assume there is an @install@ target. Note that we assume that --- this does *not* register the package! --- --- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. --- The @copy@ target should probably just invoke @make install@ --- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) --- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make --- install@ directly here is that we don\'t know the value of @$(prefix)@. --- --- [SDistCmd] We assume there is a @dist@ target. --- --- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. --- --- [UnregisterCmd] We assume there is an @unregister@ target. --- --- [HaddockCmd] We assume there is a @docs@ or @doc@ target. - - --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Make ( - module Distribution.Package, - License(..), Version(..), - defaultMain, defaultMainArgs, defaultMainNoRead - ) where - --- local -import Distribution.Package --must not specify imports, since we're exporting moule. -import Distribution.Simple.Program(defaultProgramConfiguration) -import Distribution.PackageDescription -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Utils (rawSystemExit, cabalVersion) - -import Distribution.License (License(..)) -import Distribution.Version - ( Version(..) ) -import Distribution.Text - ( display ) - -import System.Environment (getArgs, getProgName) -import Data.List (intersperse) -import System.Exit - -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainArgs - -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper - -{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} -defaultMainNoRead :: PackageDescription -> IO () -defaultMainNoRead = const defaultMain - -defaultMainHelper :: [String] -> IO () -defaultMainHelper args = - case commandsRun globalCommand commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (concat (intersperse "\n" errs)) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ display cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ display cabalVersion - - progs = defaultProgramConfiguration - commands = - [configureCommand progs `commandAddAction` configureAction - ,buildCommand progs `commandAddAction` buildAction - ,installCommand `commandAddAction` installAction - ,copyCommand `commandAddAction` copyAction - ,haddockCommand `commandAddAction` haddockAction - ,cleanCommand `commandAddAction` cleanAction - ,sdistCommand `commandAddAction` sdistAction - ,registerCommand `commandAddAction` registerAction - ,unregisterCommand `commandAddAction` unregisterAction - ] - -configureAction :: ConfigFlags -> [String] -> IO () -configureAction flags args = do - noExtraFlags args - let verbosity = fromFlag (configVerbosity flags) - rawSystemExit verbosity "sh" $ - "configure" - : configureArgs backwardsCompatHack flags - where backwardsCompatHack = True - -copyAction :: CopyFlags -> [String] -> IO () -copyAction flags args = do - noExtraFlags args - let destArgs = case fromFlag $ copyDest' flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - CopyPrefix path -> ["install", "prefix=" ++ path] - -- CopyPrefix is backwards compat, DEPRECATED - rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs - -installAction :: InstallFlags -> [String] -> IO () -installAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] - -haddockAction :: HaddockFlags -> [String] -> IO () -haddockAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] - `catch` \_ -> - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] - -buildAction :: BuildFlags -> [String] -> IO () -buildAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] - -cleanAction :: CleanFlags -> [String] -> IO () -cleanAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] - -sdistAction :: SDistFlags -> [String] -> IO () -sdistAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] - -registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] - -unregisterAction :: RegisterFlags -> [String] -> IO () -unregisterAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/Distribution/Package.hs b/Distribution/Package.hs deleted file mode 100644 --- a/Distribution/Package.hs +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Package --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Packages are fundamentally just a name and a version. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Package ( - -- * Package ids - PackageIdentifier(..), - parsePackageName, - - -- * Package dependencies - Dependency(..), - thisPackageVersion, - notThisPackageVersion, - - -- * Package classes - Package(..), packageName, packageVersion, - PackageFixedDeps(..), - - -- * Deprecated compat stuff - showPackageId, - ) where - -import Distribution.Version - ( Version(..), VersionRange(AnyVersion,ThisVersion), notThisVersion ) - -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((<++)) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>)) -import qualified Data.Char as Char ( isDigit, isAlphaNum ) -import Data.List ( intersperse ) - --- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: String, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Read, Show, Eq, Ord) - -instance Text PackageIdentifier where - disp (PackageIdentifier n v) = case v of - Version [] _ -> Disp.text n -- if no version, don't show version. - _ -> Disp.text n <> Disp.char '-' <> disp v - - parse = do - n <- parsePackageName - v <- (Parse.char '-' >> parse) <++ return (Version [] []) - return (PackageIdentifier n v) - -parsePackageName :: Parse.ReadP r String -parsePackageName = do ns <- Parse.sepBy1 component (Parse.char '-') - return (concat (intersperse "-" ns)) - where component = do - cs <- Parse.munch1 Char.isAlphaNum - if all Char.isDigit cs then Parse.pfail else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - --- ------------------------------------------------------------ --- * Package dependencies --- ------------------------------------------------------------ - -data Dependency = Dependency String VersionRange - deriving (Read, Show, Eq) - -instance Text Dependency where - disp (Dependency name ver) = - Disp.text name <+> disp ver - - parse = do name <- parsePackageName - Parse.skipSpaces - ver <- parse <++ return AnyVersion - Parse.skipSpaces - return (Dependency name ver) - -thisPackageVersion :: PackageIdentifier -> Dependency -thisPackageVersion (PackageIdentifier n v) = - Dependency n (ThisVersion v) - -notThisPackageVersion :: PackageIdentifier -> Dependency -notThisPackageVersion (PackageIdentifier n v) = - Dependency n (notThisVersion v) - --- | Class of things that can be identified by 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. --- -class Package pkg where - packageId :: pkg -> PackageIdentifier - -packageName :: Package pkg => pkg -> String -packageName = pkgName . packageId - -packageVersion :: Package pkg => pkg -> Version -packageVersion = pkgVersion . packageId - -instance Package PackageIdentifier where - packageId = id - --- | Subclass of packages that have specific versioned dependencies. --- --- So for example a not-yet-configured package has dependencies on version --- ranges, not specific versions. A configured or an already installed package --- depends on exact versions. Some operations or data structures (like --- dependency graphs) only make sense on this subclass of package types. --- -class Package pkg => PackageFixedDeps pkg where - depends :: pkg -> [PackageIdentifier] - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -{-# DEPRECATED showPackageId "use the Text class instead" #-} -showPackageId :: PackageIdentifier -> String -showPackageId = display diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs deleted file mode 100644 --- a/Distribution/PackageDescription.hs +++ /dev/null @@ -1,1330 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Package description and parsing. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.PackageDescription ( - -- * Package descriptions - PackageDescription(..), - GenericPackageDescription(..), - emptyPackageDescription, - readPackageDescription, - writePackageDescription, - parsePackageDescription, - showPackageDescription, - BuildType(..), - knownBuildTypes, - - -- ** Libraries - Library(..), - emptyLibrary, - withLib, - hasLibs, - libModules, - - -- ** Executables - Executable(..), - emptyExecutable, - withExe, - hasExes, - exeModules, - - -- ** Parsing - FieldDescr(..), - LineNo, - - -- * Build information - BuildInfo(..), - emptyBuildInfo, - allBuildInfo, - hcOptions, - - -- ** Supplementary build information - HookedBuildInfo, - emptyHookedBuildInfo, - updatePackageDescription, - - -- * package configuration - Flag(..), FlagName(..), FlagAssignment, - CondTree(..), ConfVar(..), Condition(..), - freeVars, - - -- ** Supplementary build information - readHookedBuildInfo, - parseHookedBuildInfo, - writeHookedBuildInfo, - showHookedBuildInfo, - - -- * Deprecated compat stuff - ParseResult(..), - setupMessage, - cabalVersion, - ) where - -import Data.Maybe (listToMaybe) -import Data.List (nub, unfoldr, partition, (\\)) -import Data.Monoid (Monoid(mempty, mappend)) -import Text.PrettyPrint.HughesPJ as Disp -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((+++)) -import qualified Data.Char as Char (isAlphaNum, isSpace) -import Control.Monad (liftM, foldM, when, unless) -import System.Directory (doesFileExist) - -import Distribution.Package - ( PackageIdentifier(..), Dependency, Package(..) - , parsePackageName, packageName, packageVersion ) -import Distribution.Version - ( Version(Version), VersionRange(AnyVersion) - , isAnyVersion, withinRange ) -import Distribution.License (License(AllRightsReserved)) -import Distribution.Compiler (CompilerFlavor(..)) -import Distribution.System (OS, Arch) -import Distribution.ParseUtils -import Distribution.Text - ( Text(..), display, simpleParse ) -import Distribution.Simple.Utils - ( notice, die, dieWithLocation, warn, intercalate - , lowercase, cabalVersion, readUTF8File, writeUTF8File ) -import Language.Haskell.Extension (Extension) -import Distribution.Verbosity (Verbosity) - - --- ----------------------------------------------------------------------------- --- The PackageDescription type - --- | This data type is the internal representation of the file @pkg.cabal@. --- It contains two kinds of information about the package: information --- which is needed for all packages, such as the package name and version, and --- information which is needed for the simple build system only, such as --- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - package :: PackageIdentifier, - license :: License, - licenseFile :: FilePath, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: String, - pkgUrl :: String, - synopsis :: String, -- ^A one-line summary of this package - description :: String, -- ^A more verbose description of this package - category :: String, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - buildDepends :: [Dependency], - descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here. - buildType :: Maybe BuildType, - -- components - library :: Maybe Library, - executables :: [Executable], - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath] - } - deriving (Show, Read, Eq) - -instance Package PackageDescription where - packageId = package - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription {package = PackageIdentifier "" (Version [] []), - license = AllRightsReserved, - licenseFile = "", - descCabalVersion = AnyVersion, - buildType = Nothing, - copyright = "", - maintainer = "", - author = "", - stability = "", - testedWith = [], - buildDepends = [], - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - customFieldsPD = [], - library = Nothing, - executables = [], - dataFiles = [], - dataDir = "", - extraSrcFiles = [], - extraTmpFiles = [] - } - --- | The type of build system used by this package. -data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - | UnknownBuildType String - -- ^ a package that uses an unknown build type cannot actually - -- be built. Doing it this way rather than just giving a - -- parse error means we get better error messages and allows - -- you to inspect the rest of the package description. - deriving (Show, Read, Eq) - -knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] - -instance Text BuildType where - disp (UnknownBuildType other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - name <- Parse.munch1 Char.isAlphaNum - return $ case name of - "Simple" -> Simple - "Configure" -> Configure - "Custom" -> Custom - "Make" -> Make - _ -> UnknownBuildType name - --- --------------------------------------------------------------------------- --- The Library type - -data Library = Library { - exposedModules :: [String], - libBuildInfo :: BuildInfo - } - deriving (Show, Eq, Read) - -instance Monoid Library where - mempty = nullLibrary - mappend = unionLibrary - -emptyLibrary :: Library -emptyLibrary = Library [] emptyBuildInfo - -nullLibrary :: Library -nullLibrary = Library [] nullBuildInfo - --- |does this package have any libraries? -hasLibs :: PackageDescription -> Bool -hasLibs p = maybe False (buildable . libBuildInfo) (library p) - --- |'Maybe' version of 'hasLibs' -maybeHasLibs :: PackageDescription -> Maybe Library -maybeHasLibs p = - library p >>= \lib -> if buildable (libBuildInfo lib) - then Just lib - else Nothing - --- |If the package description has a library section, call the given --- function with the library build info as argument. -withLib :: PackageDescription -> a -> (Library -> IO a) -> IO a -withLib pkg_descr a f = - maybe (return a) f (maybeHasLibs pkg_descr) - --- |Get all the module names from the libraries in this package -libModules :: PackageDescription -> [String] -libModules PackageDescription{library=lib} - = maybe [] exposedModules lib - ++ maybe [] (otherModules . libBuildInfo) lib - -unionLibrary :: Library -> Library -> Library -unionLibrary l1 l2 = - l1 { exposedModules = combine exposedModules - , libBuildInfo = unionBuildInfo (libBuildInfo l1) (libBuildInfo l2) - } - where combine f = f l1 ++ f l2 - --- --------------------------------------------------------------------------- --- The Executable type - -data Executable = Executable { - exeName :: String, - modulePath :: FilePath, - buildInfo :: BuildInfo - } - deriving (Show, Read, Eq) - -instance Monoid Executable where - mempty = nullExecutable - mappend = unionExecutable - -emptyExecutable :: Executable -emptyExecutable = Executable { - exeName = "", - modulePath = "", - buildInfo = emptyBuildInfo - } - -nullExecutable :: Executable -nullExecutable = emptyExecutable { buildInfo = nullBuildInfo } - --- |does this package have any executables? -hasExes :: PackageDescription -> Bool -hasExes p = any (buildable . buildInfo) (executables p) - --- | Perform the action on each buildable 'Executable' in the package --- description. -withExe :: PackageDescription -> (Executable -> IO a) -> IO () -withExe pkg_descr f = - sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] - --- |Get all the module names from the exes in this package -exeModules :: PackageDescription -> [String] -exeModules PackageDescription{executables=execs} - = concatMap (otherModules . buildInfo) execs - -unionExecutable :: Executable -> Executable -> Executable -unionExecutable e1 e2 = - e1 { exeName = combine exeName - , modulePath = combine modulePath - , buildInfo = unionBuildInfo (buildInfo e1) (buildInfo e2) - } - where combine f = case (f e1, f e2) of - ("","") -> "" - ("", x) -> x - (x, "") -> x - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - --- --------------------------------------------------------------------------- --- The BuildInfo type - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - buildable :: Bool, -- ^ component is buildable here - buildTools :: [Dependency], -- ^ tools needed to build this bit - cppOptions :: [String], -- ^ options for pre-processing Haskell code - ccOptions :: [String], -- ^ options for C compiler - ldOptions :: [String], -- ^ options for linker - pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - cSources :: [FilePath], - hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy - otherModules :: [String], -- ^ non-exposed or non-main modules - extensions :: [Extension], - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - extraLibDirs :: [String], - includeDirs :: [FilePath], -- ^directories to find .h files - includes :: [FilePath], -- ^ The .h files to be found in includeDirs - installIncludes :: [FilePath], -- ^ .h files to install with the package - options :: [(CompilerFlavor,[String])], - ghcProfOptions :: [String], - ghcSharedOptions :: [String], - customFieldsBI :: [(String,String)] -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - } - deriving (Show,Read,Eq) - -instance Monoid BuildInfo where - mempty = nullBuildInfo - mappend = unionBuildInfo - -nullBuildInfo :: BuildInfo -nullBuildInfo = BuildInfo { - buildable = True, - buildTools = [], - cppOptions = [], - ccOptions = [], - ldOptions = [], - pkgconfigDepends = [], - frameworks = [], - cSources = [], - hsSourceDirs = [], - otherModules = [], - extensions = [], - extraLibs = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - installIncludes = [], - options = [], - ghcProfOptions = [], - ghcSharedOptions = [], - customFieldsBI = [] - } - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = nullBuildInfo - --- | The 'BuildInfo' for the library (if there is one and it's buildable) and --- all the buildable executables. Useful for gathering dependencies. -allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] - , let bi = libBuildInfo lib - , buildable bi ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe - , buildable bi ] - -type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) - --- |Select options for a particular Haskell compiler. -hcOptions :: CompilerFlavor -> BuildInfo -> [String] -hcOptions hc bi = [ opt | (hc',opts) <- options bi - , hc' == hc - , opt <- opts ] - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) - } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = unionBuildInfo bi (libBuildInfo lib)}) - updateLibrary Nothing mb_lib = mb_lib - - --the lib only exists in the buildinfo file. FIX: Is this - --wrong? If there aren't any exposedModules, then the library - --won't build anyway. add to sanity checker? - updateLibrary (Just bi) Nothing = Just emptyLibrary{libBuildInfo=bi} - - updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^libst with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = unionBuildInfo bi (buildInfo exe)} : exes - | otherwise = exe : updateExecutable exe_bi' exes - -unionBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo -unionBuildInfo b1 b2 - = BuildInfo { - buildable = buildable b1 && buildable b2, - buildTools = combineNub buildTools, - cppOptions = combine cppOptions, - ccOptions = combine ccOptions, - ldOptions = combine ldOptions, - pkgconfigDepends = combineNub pkgconfigDepends, - frameworks = combineNub frameworks, - cSources = combineNub cSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - extensions = combineNub extensions, - extraLibs = combine extraLibs, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - installIncludes = combineNub installIncludes, - options = combine options, - ghcProfOptions = combine ghcProfOptions, - ghcSharedOptions = combine ghcSharedOptions, - customFieldsBI = combine customFieldsBI - } - where - combine f = f b1 ++ f b2 - combineNub f = nub (combine f) - --- --------------------------------------------------------------------------- --- The GenericPackageDescription type - -data GenericPackageDescription = - GenericPackageDescription { - packageDescription :: PackageDescription, - genPackageFlags :: [Flag], - condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), - condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] - } - deriving (Show) - -instance Package GenericPackageDescription where - packageId = packageId . packageDescription - -{- --- XXX: I think we really want a PPrint or Pretty or ShowPretty class. -instance Show GenericPackageDescription where - show (GenericPackageDescription pkg flgs mlib exes) = - showPackageDescription pkg ++ "\n" ++ - (render $ vcat $ map ppFlag flgs) ++ "\n" ++ - render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib) - ++ "\n" ++ - (render $ vcat $ - map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes) - where - ppFlag (MkFlag name desc dflt) = - showStanza ("Flag " ++ name) - ((if (null desc) then empty else - text ("Description: " ++ desc)) $+$ - text ("Default: " ++ show dflt)) - showDeps = fsep . punctuate comma . map showDependency - showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace --} - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data Flag = MkFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - } - deriving Show - --- | A 'FlagName' is the name of a user-defined configuration flag -newtype FlagName = FlagName String - deriving (Eq, Ord, Show, Read) - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- -type FlagAssignment = [(FlagName, Bool)] - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | Flag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show) - ---instance Text ConfVar where --- disp (OS os) = "os(" ++ display os ++ ")" --- disp (Arch arch) = "arch(" ++ display arch ++ ")" --- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")" --- disp (Impl c v) = "impl(" ++ display c --- ++ " " ++ display v ++ ")" - --- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving Show - ---instance Text c => Text (Condition c) where --- disp (Var x) = text (show x) --- disp (Lit b) = text (show b) --- disp (CNot c) = char '!' <> parens (ppCond c) --- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2] --- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2] - -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [( Condition v - , CondTree v c a - , Maybe (CondTree v c a))] - } - deriving Show - ---instance (Text v, Text c) => Text (CondTree v c a) where --- disp (CondNode _dat cs ifs) = --- (text "build-depends: " <+> --- disp cs) --- $+$ --- (vcat $ map ppIf ifs) --- where --- ppIf (c,thenTree,mElseTree) = --- ((text "if" <+> ppCond c <> colon) $$ --- nest 2 (ppCondTree thenTree disp)) --- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp)) --- mElseTree) - -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | Flag f <- freeVars' t ] - where - freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -{-# DEPRECATED setupMessage "it's exported from the Utils module now" #-} -setupMessage :: Verbosity -> String -> PackageDescription -> IO () -setupMessage verbosity msg pkg_descr = - notice verbosity (msg ++ ' ': display (packageId pkg_descr) ++ "...") - --- ----------------------------------------------------------------------------- --- The PackageDescription type - -pkgDescrFieldDescrs :: [FieldDescr PackageDescription] -pkgDescrFieldDescrs = - [ simpleField "name" - text parsePackageName - packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) - , simpleField "version" - disp parse - packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) - , simpleField "cabal-version" - disp parse - descCabalVersion (\v pkg -> pkg{descCabalVersion=v}) - , simpleField "build-type" - (maybe empty disp) (fmap Just parse) - buildType (\t pkg -> pkg{buildType=t}) - , simpleField "license" - disp parseLicenseQ - license (\l pkg -> pkg{license=l}) - , simpleField "license-file" - showFilePath parseFilePathQ - licenseFile (\l pkg -> pkg{licenseFile=l}) - , simpleField "copyright" - showFreeText (Parse.munch (const True)) - copyright (\val pkg -> pkg{copyright=val}) - , simpleField "maintainer" - showFreeText (Parse.munch (const True)) - maintainer (\val pkg -> pkg{maintainer=val}) - , commaListField "build-depends" - disp parse - buildDepends (\xs pkg -> pkg{buildDepends=xs}) - , simpleField "stability" - showFreeText (Parse.munch (const True)) - stability (\val pkg -> pkg{stability=val}) - , simpleField "homepage" - showFreeText (Parse.munch (const True)) - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText (Parse.munch (const True)) - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "synopsis" - showFreeText (Parse.munch (const True)) - synopsis (\val pkg -> pkg{synopsis=val}) - , simpleField "description" - showFreeText (Parse.munch (const True)) - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText (Parse.munch (const True)) - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText (Parse.munch (const True)) - author (\val pkg -> pkg{author=val}) - , listField "tested-with" - showTestedWith parseTestedWithQ - testedWith (\val pkg -> pkg{testedWith=val}) - , listField "data-files" - showFilePath parseFilePathQ - dataFiles (\val pkg -> pkg{dataFiles=val}) - , simpleField "data-dir" - showFilePath parseFilePathQ - dataDir (\val pkg -> pkg{dataDir=val}) - , listField "extra-source-files" - showFilePath parseFilePathQ - extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) - , listField "extra-tmp-files" - showFilePath parseFilePathQ - extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) - ] - --- | Store any fields beginning with "x-" in the customFields field of --- a PackageDescription. All other fields will generate a warning. -storeXFieldsPD :: UnrecFieldParser PackageDescription -storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = (f,val):(customFieldsPD pkg) } -storeXFieldsPD _ _ = Nothing - --- --------------------------------------------------------------------------- --- The Library type - -libFieldDescrs :: [FieldDescr Library] -libFieldDescrs = map biToLib binfoFieldDescrs - ++ [ - listField "exposed-modules" text parseModuleNameQ - exposedModules (\mods lib -> lib{exposedModules=mods}) - ] - where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) - -storeXFieldsLib :: UnrecFieldParser Library -storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = - Just $ l {libBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi) }} -storeXFieldsLib _ _ = Nothing - --- --------------------------------------------------------------------------- --- The Executable type - - -executableFieldDescrs :: [FieldDescr Executable] -executableFieldDescrs = - [ -- note ordering: configuration must come first, for - -- showPackageDescription. - simpleField "executable" - showToken parseTokenQ - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" - showFilePath parseFilePathQ - modulePath (\xs exe -> exe{modulePath=xs}) - ] - ++ map biToExe binfoFieldDescrs - where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) - -storeXFieldsExe :: UnrecFieldParser Executable -storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = - Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} -storeXFieldsExe _ _ = Nothing - --- --------------------------------------------------------------------------- --- The BuildInfo type - - -binfoFieldDescrs :: [FieldDescr BuildInfo] -binfoFieldDescrs = - [ boolField "buildable" - buildable (\val binfo -> binfo{buildable=val}) - , commaListField "build-tools" - disp parseBuildTool - buildTools (\xs binfo -> binfo{buildTools=xs}) - , listField "cpp-options" - showToken parseTokenQ - cppOptions (\val binfo -> binfo{cppOptions=val}) - , listField "cc-options" - showToken parseTokenQ - ccOptions (\val binfo -> binfo{ccOptions=val}) - , listField "ld-options" - showToken parseTokenQ - ldOptions (\val binfo -> binfo{ldOptions=val}) - , commaListField "pkgconfig-depends" - disp parsePkgconfigDependency - pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) - , listField "frameworks" - showToken parseTokenQ - frameworks (\val binfo -> binfo{frameworks=val}) - , listField "c-sources" - showFilePath parseFilePathQ - cSources (\paths binfo -> binfo{cSources=paths}) - , listField "extensions" - disp parseExtensionQ - extensions (\exts binfo -> binfo{extensions=exts}) - , listField "extra-libraries" - showToken parseTokenQ - extraLibs (\xs binfo -> binfo{extraLibs=xs}) - , listField "extra-lib-dirs" - showFilePath parseFilePathQ - extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) - , listField "includes" - showFilePath parseFilePathQ - includes (\paths binfo -> binfo{includes=paths}) - , listField "install-includes" - showFilePath parseFilePathQ - installIncludes (\paths binfo -> binfo{installIncludes=paths}) - , listField "include-dirs" - showFilePath parseFilePathQ - includeDirs (\paths binfo -> binfo{includeDirs=paths}) - , listField "hs-source-dirs" - showFilePath parseFilePathQ - hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) - , listField "other-modules" - text parseModuleNameQ - otherModules (\val binfo -> binfo{otherModules=val}) - , listField "ghc-prof-options" - text parseTokenQ - ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) - , listField "ghc-shared-options" - text parseTokenQ - ghcProfOptions (\val binfo -> binfo{ghcSharedOptions=val}) - , optsField "ghc-options" GHC - options (\path binfo -> binfo{options=path}) - , optsField "hugs-options" Hugs - options (\path binfo -> binfo{options=path}) - , optsField "nhc98-options" NHC - options (\path binfo -> binfo{options=path}) - , optsField "jhc-options" JHC - options (\path binfo -> binfo{options=path}) - ] - -storeXFieldsBI :: UnrecFieldParser BuildInfo -storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } -storeXFieldsBI _ _ = Nothing - ------------------------------------------------------------------------------- - -flagFieldDescrs :: [FieldDescr Flag] -flagFieldDescrs = - [ simpleField "description" - showFreeText (Parse.munch (const True)) - flagDescription (\val fl -> fl{ flagDescription = val }) - , boolField "default" - flagDefault (\val fl -> fl{ flagDefault = val }) - ] - --- --------------------------------------------------------------- --- Parsing - --- | Given a parser and a filename, return the parse of the file, --- after checking if the file exists. -readAndParseFile :: (FilePath -> IO String) - -> (String -> ParseResult a) - -> Verbosity - -> FilePath -> IO a -readAndParseFile readFile' parser verbosity fpath = do - exists <- doesFileExist fpath - when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") - str <- readFile' fpath - case parser str of - ParseFailed e -> do - let (line, message) = locatedErrorMsg e - dieWithLocation fpath line message - ParseOk warnings x -> do - mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings - return x - -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -readHookedBuildInfo = - readAndParseFile readFile parseHookedBuildInfo - --- |Parse the given package file. -readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readPackageDescription = - readAndParseFile readUTF8File parsePackageDescription - -stanzas :: [Field] -> [[Field]] -stanzas [] = [] -stanzas (f:fields) = (f:this) : stanzas rest - where - (this, rest) = break isStanzaHeader fields - -isStanzaHeader :: Field -> Bool -isStanzaHeader (F _ f _) = f == "executable" -isStanzaHeader _ = False - ------------------------------------------------------------------------------- - - -mapSimpleFields :: (Field -> ParseResult Field) -> [Field] - -> ParseResult [Field] -mapSimpleFields f fs = mapM walk fs - where - walk fld@(F _ _ _) = f fld - walk (IfBlock l c fs1 fs2) = do - fs1' <- mapM walk fs1 - fs2' <- mapM walk fs2 - return (IfBlock l c fs1' fs2') - walk (Section ln n l fs1) = do - fs1' <- mapM walk fs1 - return (Section ln n l fs1') - --- prop_isMapM fs = mapSimpleFields return fs == return fs - - --- names of fields that represents dependencies, thus consrca -constraintFieldNames :: [String] -constraintFieldNames = ["build-depends"] - --- Possible refactoring would be to have modifiers be explicit about what --- they add and define an accessor that specifies what the dependencies --- are. This way we would completely reuse the parsing knowledge from the --- field descriptor. -parseConstraint :: Field -> ParseResult [Dependency] -parseConstraint (F l n v) - | n == "build-depends" = runP l n (parseCommaList parse) v -parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" - -{- -headerFieldNames :: [String] -headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) - . map fieldName $ pkgDescrFieldDescrs --} - -libFieldNames :: [String] -libFieldNames = map fieldName libFieldDescrs - ++ buildInfoNames ++ constraintFieldNames - --- exeFieldNames :: [String] --- exeFieldNames = map fieldName executableFieldDescrs --- ++ buildInfoNames - -buildInfoNames :: [String] -buildInfoNames = map fieldName binfoFieldDescrs - ++ map fst deprecatedFieldsBuildInfo - --- A minimal implementation of the StateT monad transformer to avoid depending --- on the 'mtl' package. -newtype StT s m a = StT { runStT :: s -> m (a,s) } - -instance Monad m => Monad (StT s m) where - return a = StT (\s -> return (a,s)) - StT f >>= g = StT $ \s -> do - (a,s') <- f s - runStT (g a) s' - -get :: Monad m => StT s m s -get = StT $ \s -> return (s, s) - -modify :: Monad m => (s -> s) -> StT s m () -modify f = StT $ \s -> return ((),f s) - -lift :: Monad m => m a -> StT s m a -lift m = StT $ \s -> m >>= \a -> return (a,s) - -evalStT :: Monad m => StT s m a -> s -> m a -evalStT st s = runStT st s >>= return . fst - --- Our monad for parsing a list/tree of fields. --- --- The state represents the remaining fields to be processed. -type PM a = StT [Field] ParseResult a - - - --- return look-ahead field or nothing if we're at the end of the file -peekField :: PM (Maybe Field) -peekField = get >>= return . listToMaybe - --- Unconditionally discard the first field in our state. Will error when it --- reaches end of file. (Yes, that's evil.) -skipField :: PM () -skipField = modify tail - --- | Parses the given file into a 'GenericPackageDescription'. --- --- In Cabal 1.2 the syntax for package descriptions was changed to a format --- with sections and possibly indented property descriptions. -parsePackageDescription :: String -> ParseResult GenericPackageDescription -parsePackageDescription file = do - let tabs = findIndentTabs file - - fields0 <- readFields file `catchParseError` \err -> - case err of - -- In case of a TabsError report them all at once. - TabsError tabLineNo -> reportTabsError - -- but only report the ones including and following - -- the one that caused the actual error - [ t | t@(lineNo',_) <- tabs - , lineNo' >= tabLineNo ] - _ -> parseFail err - - let cabalVersionNeeded = - head $ [ versionRange - | Just versionRange <- [ simpleParse v - | F _ "cabal-version" v <- fields0 ] ] - ++ [AnyVersion] - handleFutureVersionParseFailure cabalVersionNeeded $ do - - let sf = sectionizeFields fields0 - fields <- mapSimpleFields deprecField sf - - flip evalStT fields $ do - hfs <- getHeader [] - pkg <- lift $ parseFields pkgDescrFieldDescrs storeXFieldsPD emptyPackageDescription hfs - (flags, mlib, exes) <- getBody - warnIfRest - when (not (oldSyntax fields0)) $ - maybeWarnCabalVersion pkg - checkForUndefinedFlags flags mlib exes - return (GenericPackageDescription pkg flags mlib exes) - - where - oldSyntax flds = all isSimpleField flds - reportTabsError tabs = - syntaxError (fst (head tabs)) $ - "Do not use tabs for indentation (use spaces instead)\n" - ++ " Tabs were used at (line,column): " ++ show tabs - maybeWarnCabalVersion pkg = - when (packageName pkg /= "Cabal" -- supress warning for Cabal - && isAnyVersion (descCabalVersion pkg)) $ - lift $ warning $ - "A package using section syntax should require\n" - ++ "\"Cabal-Version: >= 1.2\" or equivalent." - - handleFutureVersionParseFailure cabalVersionNeeded parseBody = - (unless versionOk (warning message) >> parseBody) - `catchParseError` \parseError -> case parseError of - TabsError _ -> parseFail parseError - _ | versionOk -> parseFail parseError - | otherwise -> fail message - where versionOk = cabalVersion `withinRange` cabalVersionNeeded - message = "This package requires Cabal version: " - ++ display cabalVersionNeeded - - -- "Sectionize" an old-style Cabal file. A sectionized file has: - -- - -- * all global fields at the beginning, followed by - -- * all flag declarations, followed by - -- * an optional library section, and - -- * an arbitrary number of executable sections. - -- - -- The current implementatition just gathers all library-specific fields - -- in a library section and wraps all executable stanzas in an executable - -- section. - sectionizeFields :: [Field] -> [Field] - sectionizeFields fs - | oldSyntax fs = - let - -- "build-depends" is a local field now. To be backwards - -- compatible, we still allow it as a global field in old-style - -- package description files and translate it to a local field by - -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . fName) fs - (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 - - (deps, libfs) = partition ((== "build-depends") . fName) - libfs0 - - exes = unfoldr toExe exes0 - toExe [] = Nothing - toExe (F l e n : r) - | e == "executable" = - let (efs, r') = break ((=="executable") . fName) r - in Just (Section l "executable" n (deps ++ efs), r') - toExe _ = bug "unexpeced input to 'toExe'" - in - hdr ++ - (if null libfs then [] - else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) - ++ exes - | otherwise = fs - - isSimpleField (F _ _ _) = True - isSimpleField _ = False - - -- warn if there's something at the end of the file - warnIfRest :: PM () - warnIfRest = do - s <- get - case s of - [] -> return () - _ -> lift $ warning "Ignoring trailing declarations." -- add line no. - - -- all simple fields at the beginning of the file are (considered) header - -- fields - getHeader :: [Field] -> PM [Field] - getHeader acc = peekField >>= \mf -> case mf of - Just f@(F _ _ _) -> skipField >> getHeader (f:acc) - _ -> return (reverse acc) - - -- - -- body ::= flag* { library | executable }+ -- at most one lib - -- - -- The body consists of an optional sequence of flag declarations and after - -- that an arbitrary number of executables and an optional library. The - -- order of the latter doesn't play a role. - getBody :: PM ([Flag] - ,Maybe (CondTree ConfVar [Dependency] Library) - ,[(String, CondTree ConfVar [Dependency] Executable)]) - getBody = do - mf <- peekField - case mf of - Just (Section _ sn _label _fields) - | sn == "flag" -> do - -- don't skipField here. it's simpler to let getFlags do it - -- itself - flags <- getFlags [] - (lib, exes) <- getLibOrExe - return (flags, lib, exes) - | otherwise -> do - (lib,exes) <- getLibOrExe - return ([], lib, exes) - Nothing -> do lift $ warning "No library or executable specified" - return ([], Nothing, []) - Just f -> lift $ syntaxError (lineNo f) $ - "Construct not supported at this position: " ++ show f - - -- - -- flags ::= "flag:" name { flag_prop } - -- - getFlags :: [Flag] -> StT [Field] ParseResult [Flag] - getFlags acc = peekField >>= \mf -> case mf of - Just (Section _ sn sl fs) - | sn == "flag" -> do - fl <- lift $ parseFields - flagFieldDescrs - warnUnrec - (MkFlag (FlagName (lowercase sl)) "" True) - fs - skipField >> getFlags (fl : acc) - _ -> return (reverse acc) - - getLibOrExe :: PM (Maybe (CondTree ConfVar [Dependency] Library) - ,[(String, CondTree ConfVar [Dependency] Executable)]) - getLibOrExe = peekField >>= \mf -> case mf of - Just (Section n sn sl fs) - | sn == "executable" -> do - when (null sl) $ lift $ - syntaxError n "'executable' needs one argument (the executable's name)" - exename <- lift $ runP n "executable" parseTokenQ sl - flds <- collectFields parseExeFields fs - skipField - (lib, exes) <- getLibOrExe - return (lib, exes ++ [(exename, flds)]) - | sn == "library" -> do - when (not (null sl)) $ lift $ - syntaxError n "'library' expects no argument" - flds <- collectFields parseLibFields fs - skipField - (lib, exes) <- getLibOrExe - return (maybe (Just flds) - (const (error "Multiple libraries specified")) - lib - , exes) - | otherwise -> do - lift $ warning $ "Unknown section type: " ++ sn ++ " ignoring..." - return (Nothing, []) -- yep - Just x -> lift $ syntaxError (lineNo x) $ "Section expected." - Nothing -> return (Nothing, []) - - -- extracts all fields in a block, possibly add dependencies to the - -- guard condition - collectFields :: ([Field] -> PM a) -> [Field] - -> PM (CondTree ConfVar [Dependency] a) - collectFields parser allflds = do - a <- parser dataFlds - deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds - ifs <- mapM processIfs condFlds - return (CondNode a deps ifs) - where - (depFlds, dataFlds) = partition isConstraint simplFlds - simplFlds = [ F l n v | F l n v <- allflds ] - condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] - isConstraint (F _ n _) = n `elem` constraintFieldNames - isConstraint _ = False - processIfs (IfBlock l c t e) = do - cnd <- lift $ runP l "if" parseCondition c - t' <- collectFields parser t - e' <- case e of - [] -> return Nothing - es -> do fs <- collectFields parser es - return (Just fs) - return (cnd, t', e') - processIfs _ = bug "processIfs called with wrong field type" - - parseLibFields :: [Field] -> StT s ParseResult Library - parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary - - parseExeFields :: [Field] -> StT s ParseResult Executable - parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable - - checkForUndefinedFlags :: - [Flag] -> - Maybe (CondTree ConfVar [Dependency] Library) -> - [(String, CondTree ConfVar [Dependency] Executable)] -> - PM () - checkForUndefinedFlags flags mlib exes = do - let definedFlags = map flagName flags - maybe (return ()) (checkCondTreeFlags definedFlags) mlib - mapM_ (checkCondTreeFlags definedFlags . snd) exes - - checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () - checkCondTreeFlags definedFlags ct = do - let fv = nub $ freeVars ct - when (not . all (`elem` definedFlags) $ fv) $ - fail $ "These flags are used without having been defined: " - ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] - - --- | Parse a list of fields, given a list of field descriptions, --- a structure to accumulate the parsed fields, and a function --- that can decide what to do with fields which don't match any --- of the field descriptions. -parseFields :: [FieldDescr a] -- ^ list of parseable fields - -> UnrecFieldParser a -- ^ possibly do something with - -- unrecognized fields - -> a -- ^ accumulator - -> [Field] -- ^ fields to be parsed - -> ParseResult a -parseFields descrs unrec ini fields = - do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields - when (not (null unknowns)) $ do - warning $ render $ - text "Unknown fields:" <+> - commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") - (reverse unknowns)) - $+$ - text "Fields allowed in this section:" $$ - nest 4 (commaSep $ map fieldName descrs) - return a - where - commaSep = fsep . punctuate comma . map text - -parseField :: [FieldDescr a] -- ^ list of parseable fields - -> UnrecFieldParser a -- ^ possibly do something with - -- unrecognized fields - -> (a,[(Int,String)]) -- ^ accumulated result and warnings - -> Field -- ^ the field to be parsed - -> ParseResult (a, [(Int,String)]) -parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) - | name == f = parser line val a >>= \a' -> return (a',us) - | otherwise = parseField fields unrec (a,us) (F line f val) -parseField [] unrec (a,us) (F l f val) = return $ - case unrec (f,val) a of -- no fields matched, see if the 'unrec' - Just a' -> (a',us) -- function wants to do anything with it - Nothing -> (a, ((l,f):us)) -parseField _ _ _ _ = bug "'parseField' called on a non-field" - -deprecatedFields :: [(String,String)] -deprecatedFields = - deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo - -deprecatedFieldsPkgDescr :: [(String,String)] -deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] - -deprecatedFieldsBuildInfo :: [(String,String)] -deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] - --- Handle deprecated fields -deprecField :: Field -> ParseResult Field -deprecField (F line fld val) = do - fld' <- case lookup fld deprecatedFields of - Nothing -> return fld - Just newName -> do - warning $ "The field \"" ++ fld - ++ "\" is deprecated, please use \"" ++ newName ++ "\"" - return newName - return (F line fld' val) -deprecField _ = bug "'deprecField' called on a non-field" - - -parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo -parseHookedBuildInfo inp = do - fields <- readFields inp - let ss@(mLibFields:exes) = stanzas fields - mLib <- parseLib mLibFields - biExes <- mapM parseExe (maybe ss (const exes) mLib) - return (mLib, biExes) - where - parseLib :: [Field] -> ParseResult (Maybe BuildInfo) - parseLib (bi@((F _ inFieldName _):_)) - | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) - parseLib _ = return Nothing - - parseExe :: [Field] -> ParseResult (String, BuildInfo) - parseExe ((F line inFieldName mName):bi) - | lowercase inFieldName == "executable" - = do bis <- parseBI bi - return (mName, bis) - | otherwise = syntaxError line "expecting 'executable' at top of stanza" - parseExe (_:_) = bug "`parseExe' called on a non-field" - parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" - - parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st - --- | Parse a configuration condition from a string. -parseCondition :: Parse.ReadP r (Condition ConfVar) -parseCondition = condOr - where - condOr = Parse.sepBy1 condAnd (oper "||") >>= return . foldl1 COr - condAnd = Parse.sepBy1 cond (oper "&&")>>= return . foldl1 CAnd - cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond - +++ archCond +++ flagCond +++ implCond ) - inparens = Parse.between (Parse.char '(' >> sp) (sp >> Parse.char ')' >> sp) - notCond = Parse.char '!' >> sp >> cond >>= return . CNot - osCond = Parse.string "os" >> sp >> inparens osIdent >>= return . Var - archCond = Parse.string "arch" >> sp >> inparens archIdent >>= return . Var - flagCond = Parse.string "flag" >> sp >> inparens flagIdent >>= return . Var - implCond = Parse.string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parse - archIdent = fmap Arch parse - osIdent = fmap OS parse - flagIdent = fmap (Flag . FlagName . lowercase) (Parse.munch1 isIdentChar) - isIdentChar c = Char.isAlphaNum c || c == '_' || c == '-' - oper s = sp >> Parse.string s >> sp - sp = Parse.skipSpaces - implIdent = do i <- parse - vr <- sp >> Parse.option AnyVersion parse - return $ Impl i vr - --- --------------------------------------------------------------------------- --- Pretty printing - -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) - -showPackageDescription :: PackageDescription -> String -showPackageDescription pkg = render $ - ppFields pkg pkgDescrFieldDescrs $$ - ppCustomFields (customFieldsPD pkg) $$ - (case library pkg of - Nothing -> empty - Just lib -> ppFields lib libFieldDescrs) $$ - vcat (map ppExecutable (executables pkg)) - where - ppExecutable exe = space $$ ppFields exe executableFieldDescrs - -ppCustomFields :: [(String,String)] -> Doc -ppCustomFields flds = vcat (map ppCustomField flds) - -ppCustomField :: (String,String) -> Doc -ppCustomField (name,val) = text name <> colon <+> showFreeText val - -writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath pbi = writeFile fpath (showHookedBuildInfo pbi) - -showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bi) = render $ - (case mb_lib_bi of - Nothing -> empty - Just bi -> ppFields bi binfoFieldDescrs) $$ - vcat (map ppExeBuildInfo ex_bi) - where - ppExeBuildInfo (name, bi) = - space $$ - text "executable:" <+> text name $$ - ppFields bi binfoFieldDescrs $$ - ppCustomFields (customFieldsBI bi) - --- replace all tabs used as indentation with whitespace, also return where --- tabs were found -findIndentTabs :: String -> [(Int,Int)] -findIndentTabs = concatMap checkLine - . zip [1..] - . lines - where - checkLine (lineno, l) = - let (indent, _content) = span Char.isSpace l - tabCols = map fst . filter ((== '\t') . snd) . zip [0..] - addLineNo = map (\col -> (lineno,col)) - in addLineNo (tabCols indent) - ---test_findIndentTabs = findIndentTabs $ unlines $ --- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] - -bug :: String -> a -bug msg = error $ msg ++ ". Consider this a bug." diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs deleted file mode 100644 --- a/Distribution/PackageDescription/Check.hs +++ /dev/null @@ -1,616 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Check --- Copyright : Lennart Kolmodin 2008 --- --- Maintainer : Lennart Kolmodin --- Stability : alpha --- Portability : portable --- --- This module provides functionality to check for common mistakes. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.PackageDescription.Check ( - -- * Package Checking - PackageCheck(..), - checkPackage, - checkConfiguredPackage, - checkPackageFiles - ) where - -import Data.Maybe (isNothing, catMaybes, fromMaybe) -import Data.List (sort, group, isPrefixOf) -import Control.Monad (filterM) -import System.Directory (doesFileExist, doesDirectoryExist) - -import Distribution.PackageDescription hiding (freeVars) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Compiler - ( CompilerFlavor(..) ) -import Distribution.System - ( OS(..), Arch(..) ) -import Distribution.License - ( License(..) ) -import Distribution.Simple.Utils - ( cabalVersion, intercalate ) - -import Distribution.Version - ( Version(..), withinRange ) -import Distribution.Package - ( packageName, packageVersion ) -import Distribution.Text - ( display, simpleParse ) -import Language.Haskell.Extension (Extension(..)) -import System.FilePath (takeExtension, isRelative, splitDirectories, ()) - --- | Results of some kind of failed package check. --- --- There are a range of severities, from merely dubious to totally insane. --- All of them come with a human readable explanation. In future we may augment --- them with more machine readable explanations, for example to help an IDE --- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: String } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | PackageBuildWarning { explanation :: String } - - -- | An issue that might not be a problem for the package author but - -- might be annoying or determental when the package is distributed to - -- users. We should encourage distributed packages to be free from these - -- issues, but occasionally there are justifiable reasons so we cannot - -- ban them entirely. - | PackageDistSuspicious { explanation :: String } - - -- | An issue that is ok in the author's environment but is almost - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: String } - -instance Show PackageCheck where - show notice = explanation notice - -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - --- ------------------------------------------------------------ --- * Standard checks --- ------------------------------------------------------------ - --- TODO: --- --- * check for unknown 'OS's and 'Arch's. This requires checking the --- 'GenericPackageDescription' which we do not currently get passed. - --- | Check for common mistakes and problems in package descriptions. --- --- This is the standard collection of checks covering all apsects except --- for checks that require looking at files within the package. For those --- see 'checkPackageFiles'. --- --- It requires the 'GenericPackageDescription' and optionally a particular --- configuration of that package. If you pass 'Nothing' then we just check --- a version of the generic description using 'flattenPackageDescription'. --- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] -checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - where - pkg = fromMaybe (flattenPackageDescription gpkg) mpkg - ---TODO: make this variant go away --- we should alwaws know the GenericPackageDescription -checkConfiguredPackage :: PackageDescription -> [PackageCheck] -checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkGhcOptions pkg - ++ checkCCOptions pkg - ++ checkPaths pkg - - --- ------------------------------------------------------------ --- * Basic sanity checks --- ------------------------------------------------------------ - --- | Check that this package description is sane. --- -checkSanity :: PackageDescription -> [PackageCheck] -checkSanity pkg = - catMaybes [ - - check (null . packageName $ pkg) $ - PackageBuildImpossible "No 'name' field." - - , check (null . versionBranch . packageVersion $ pkg) $ - PackageBuildImpossible "No 'version' field." - - , check (null (executables pkg) && isNothing (library pkg)) $ - PackageBuildImpossible - "No executables and no library found. Nothing to do." - ] - - ++ maybe [] checkLibrary (library pkg) - ++ concatMap checkExecutable (executables pkg) - - ++ catMaybes [ - - check (not $ cabalVersion `withinRange` requiredCabalVersion) $ - PackageBuildImpossible $ - "This package requires Cabal version: " - ++ display requiredCabalVersion - ] - - where requiredCabalVersion = descCabalVersion pkg - -checkLibrary :: Library -> [PackageCheck] -checkLibrary lib = - catMaybes [ - - check (not (null moduleDuplicates)) $ - PackageBuildWarning $ - "Duplicate modules in library: " ++ commaSep moduleDuplicates - ] - - where moduleDuplicates = [ module_ - | let modules = exposedModules lib - ++ otherModules (libBuildInfo lib) - , (module_:_:_) <- group (sort modules) ] - -checkExecutable :: Executable -> [PackageCheck] -checkExecutable exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible $ - "No 'Main-Is' field found for executable " ++ exeName exe - - , check (not (null (modulePath exe)) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageBuildImpossible $ - "The 'Main-Is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." - - , check (not (null moduleDuplicates)) $ - PackageBuildWarning $ - "Duplicate modules in executable '" ++ exeName exe ++ "': " - ++ commaSep moduleDuplicates - ] - - where moduleDuplicates = [ module_ - | let modules = otherModules (buildInfo exe) - , (module_:_:_) <- group (sort modules) ] - --- ------------------------------------------------------------ --- * Additional pure checks --- ------------------------------------------------------------ - -checkFields :: PackageDescription -> [PackageCheck] -checkFields pkg = - catMaybes [ - - check (isNothing (buildType pkg)) $ - PackageBuildWarning $ - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." - - , case buildType pkg of - Just (UnknownBuildType unknown) -> Just $ - PackageBuildWarning $ - quote unknown ++ " is not a known 'build-type'. " - ++ "The known build types are: " - ++ intercalate ", " (map display knownBuildTypes) - _ -> Nothing - - , check (not (null unknownCompilers)) $ - PackageBuildWarning $ - "Unknown compiler " ++ intercalate ", " (map quote unknownCompilers) - ++ " in 'tested-with' field." - - , check (not (null unknownExtensions)) $ - PackageBuildWarning $ - "Unknown extensions: " ++ intercalate ", " unknownExtensions - - , check (null (category pkg)) $ - PackageDistSuspicious "No 'category' field." - - , check (null (description pkg)) $ - PackageDistSuspicious "No 'description' field." - - , check (null (maintainer pkg)) $ - PackageDistSuspicious "No 'maintainer' field." - - , check (null (synopsis pkg)) $ - PackageDistSuspicious "No 'synopsis' field." - - , check (length (synopsis pkg) >= 80) $ - PackageDistSuspicious - "The 'synopsis' field is rather long (max 80 chars is recommended)." - ] - where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- extensions bi ] - -checkLicense :: PackageDescription -> [PackageCheck] -checkLicense pkg = - catMaybes [ - - check (license pkg == AllRightsReserved) $ - PackageDistInexcusable - "The 'license' field is missing or specified as AllRightsReserved." - - , case license pkg of - UnknownLicense l -> Just $ - PackageBuildWarning $ - quote ("license: " ++ l) ++ " is not a recognised license." - _ -> Nothing - - , check (license pkg == BSD4) $ - PackageDistSuspicious $ - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." - - , check (license pkg `notElem` [AllRightsReserved, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFile pkg)) $ - PackageDistSuspicious "A 'license-file' is not specified." - ] - -checkGhcOptions :: PackageDescription -> [PackageCheck] -checkGhcOptions pkg = - catMaybes [ - - check has_WerrorWall $ - PackageDistInexcusable $ - "'ghc-options: -Wall -Werror' makes the package " - ++ "very easy to break with future GHC versions." - - , check (not has_WerrorWall && has_Werror) $ - PackageDistSuspicious $ - "'ghc-options: -Werror' makes the package easy to " - ++ "break with future GHC versions." - - , checkFlags ["-fasm"] $ - PackageDistInexcusable $ - "'ghc-options: -fasm' is unnecessary and breaks on all " - ++ "arches except for x86, x86-64 and ppc." - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious $ - "'ghc-options: -fvia-C' is usually unnecessary." - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable $ - "'ghc-options: -fhpc' is not appropriate for a distributed package." - - , check (any ("-d" `isPrefixOf`) all_ghc_options) $ - PackageDistInexcusable $ - "'ghc-options: -d*' debug flags are not appropriate for a distributed package." - - , checkFlags ["-prof"] $ - PackageDistInexcusable $ - "'ghc-options: -prof' is not needed. Use the --enable-library-profiling configure flag." - - , checkFlags ["-o"] $ - PackageDistInexcusable $ - "'ghc-options: -o' is not allowed. The output files are named automatically." - - , checkFlags ["-hide-package"] $ - PackageDistInexcusable $ - "'ghc-options: -hide-package' is never needed. Cabal hides all packages." - - , checkFlags ["-main-is"] $ - PackageDistSuspicious $ - "'ghc-options: -main-is' is not portable." - - , checkFlags ["-O0", "-Onot"] $ - PackageDistInexcusable $ - "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag." - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable $ - "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. " - ++ "Setting it yourself interferes with the --disable-optimization flag." - - , checkFlags ["-O2"] $ - PackageDistSuspicious $ - "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit " - ++ "and not just imposing longer compile times on your users." - - , checkFlags ["-split-objs"] $ - PackageDistInexcusable $ - "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." - - , checkFlags ["-optl-Wl,-s"] $ - PackageDistSuspicious $ - "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" - ++ " operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious $ - "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field." - - , checkAlternatives "ghc-options" "extensions" - [ (flag, display extension) | flag <- all_ghc_options - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives "ghc-options" "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options - , case simpleParse extension of - Just (UnknownExtension _) -> True - Just ext -> ext `elem` compatExtensions - || not (Version [1,1,6] [] - `withinRange` descCabalVersion pkg) - Nothing -> False ] - - , checkAlternatives "ghc-options" "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] - ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] - ] - - where - has_WerrorWall = flip any ghc_options $ \opts -> - "-Werror" `elem` opts - && ("-Wall" `elem` opts || "-W" `elem` opts) - has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options - - ghc_options = [ strs | bi <- allBuildInfo pkg - , (GHC, strs) <- options bi ] - all_ghc_options = concat ghc_options - - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) all_ghc_options) - - ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> Just OverlappingInstances - "th" -> Just TemplateHaskell - "ffi" -> Just ForeignFunctionInterface - "fi" -> Just ForeignFunctionInterface - "no-monomorphism-restriction" -> Just NoMonomorphismRestriction - "no-mono-pat-binds" -> Just NoMonoPatBinds - "allow-undecidable-instances" -> Just UndecidableInstances - "allow-incoherent-instances" -> Just IncoherentInstances - "arrows" -> Just Arrows - "generics" -> Just Generics - "no-implicit-prelude" -> Just NoImplicitPrelude - "implicit-params" -> Just ImplicitParams - "bang-patterns" -> Just BangPatterns - "scoped-type-variables" -> Just ScopedTypeVariables - "extended-default-rules" -> Just ExtendedDefaultRules - _ -> Nothing - ghcExtension ('-':'c':"pp") = Just CPP - ghcExtension _ = Nothing - - -- the known extensions in Cabal-1.1.6 that came with ghc-6.6: - -- we can drop this test when Cabal-1.4+ is widely deployed because - -- from that point on we can add new extensions without worrying about - -- breaking old versions of cabal. - compatExtensions = - [ OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , NoMonomorphismRestriction, FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NoImplicitPrelude, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments - ] - -checkCCOptions :: PackageDescription -> [PackageCheck] -checkCCOptions pkg = - catMaybes [ - - checkAlternatives "cc-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] - - , checkAlternatives "cc-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] - - , checkAlternatives "cc-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - ] - - where all_ccOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ccOptions bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] - -checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning $ - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - - where (badFlags, goodFlags) = unzip flags - -checkPaths :: PackageDescription -> [PackageCheck] -checkPaths pkg = - [ PackageBuildWarning { - explanation = quote (kind ++ ": " ++ dir) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." - } - | bi <- allBuildInfo pkg - , (dir, kind) <- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isOutsideTree dir ] - where isOutsideTree dir = case splitDirectories dir of - "..":_ -> True - _ -> False - --- ------------------------------------------------------------ --- * Checks on the GenericPackageDescription --- ------------------------------------------------------------ - -checkConditionals :: GenericPackageDescription -> [PackageCheck] -checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable $ - "Unknown operating system name " - ++ intercalate ", " (map quote unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable $ - "Unknown architecture name " - ++ intercalate ", " (map quote unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable $ - "Unknown compiler name " - ++ intercalate ", " (map quote unknownImpls) - ] - where - unknownOSs = [ os | OS (OtherOS os) <- conditions ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = maybe [] freeVars (condLibrary pkg) - ++ concatMap (freeVars . snd) (condExecutables pkg) - freeVars (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - --- ------------------------------------------------------------ --- * Checks in IO --- ------------------------------------------------------------ - --- | Sanity check things that requires IO. It looks at the files in the package --- and expects to find the package unpacked in at the given filepath. --- -checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] -checkPackageFiles pkg root = do - licenseError <- checkLicenseExists pkg root - setupError <- checkSetupExists pkg root - configureError <- checkConfigureExists pkg root - localPathErrors <- checkLocalPathsExist pkg root - - return $ catMaybes [licenseError, setupError, configureError] - ++ localPathErrors - -checkLicenseExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck) -checkLicenseExists pkg root - | null (licenseFile pkg) = return Nothing - | otherwise = do - exists <- doesFileExist (root file) - return $ check (not exists) $ - PackageBuildWarning $ - "The 'license-file' field refers to the file " ++ quote file - ++ " which does not exist." - - where - file = licenseFile pkg - -checkSetupExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck) -checkSetupExists _ root = do - hsexists <- doesFileExist (root "Setup.hs") - lhsexists <- doesFileExist (root "Setup.lhs") - return $ check (not hsexists && not lhsexists) $ - PackageDistInexcusable $ - "The package is missing a Setup.hs or Setup.lhs script." - -checkConfigureExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck) -checkConfigureExists PackageDescription { buildType = Just Configure } root = do - exists <- doesFileExist (root "configure") - return $ check (not exists) $ - PackageBuildWarning $ - "The 'build-type' is 'Configure' but there is no 'configure' script." -checkConfigureExists _ _ = return Nothing - -checkLocalPathsExist :: PackageDescription -> FilePath -> IO [PackageCheck] -checkLocalPathsExist pkg root = do - let dirs = [ (dir, kind) - | bi <- allBuildInfo pkg - , (dir, kind) <- - [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isRelative dir ] - missing <- filterM (fmap not . doesDirectoryExist . (root ) . fst) dirs - return [ PackageBuildWarning { - explanation = quote (kind ++ ": " ++ dir) - ++ " directory does not exist." - } - | (dir, kind) <- missing ] - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -quote :: String -> String -quote s = "'" ++ s ++ "'" - -commaSep :: [String] -> String -commaSep = intercalate "," diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs deleted file mode 100644 --- a/Distribution/PackageDescription/Configuration.hs +++ /dev/null @@ -1,503 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Configuration --- Copyright : Thomas Schilling, 2007 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Configurations - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.PackageDescription.Configuration ( - finalizePackageDescription, - flattenPackageDescription, - ) where - -import Distribution.Package (Package, Dependency(..)) -import Distribution.PackageDescription - ( GenericPackageDescription(..), PackageDescription(..) - , Library(..), Executable(..), BuildInfo(..) - , Flag(..), FlagName(..), FlagAssignment - , CondTree(..), ConfVar(..), Condition(..) ) -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Version - ( VersionRange(..), withinRange ) -import Distribution.Compiler - ( CompilerId(CompilerId) ) -import Distribution.System - ( OS, Arch ) -import Distribution.Simple.Utils (currentDir) - -import Data.Maybe ( catMaybes, maybeToList ) -import Data.List ( nub ) -import Data.Map ( Map, fromListWith, toList ) -import qualified Data.Map as M -import Data.Monoid - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) -import qualified Text.Read as R -import qualified Text.Read.Lex as L -#endif - ------------------------------------------------------------------------------- - --- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) -simplifyCondition cond i = fv . walk $ cond - where - walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' - CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' - -- gather free vars - fv c = (c, fv' c) - fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - COr c1 c2 -> fv' c1 ++ fv' c2 - CAnd c1 c2 -> fv' c1 ++ fv' c2 - --- | Simplify a configuration condition using the os and arch names. Returns --- the names of all the flags occurring in the condition. -simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar - -> (Condition FlagName, [FlagName]) -simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags) - where - (cond', flags) = simplifyCondition cond interp - interp (OS os') = Right $ os' == os - interp (Arch arch') = Right $ arch' == arch - interp (Impl comp' vr) = Right $ comp' == comp - && compVer `withinRange` vr - interp (Flag f) = Left f - --- XXX: 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 --- - ------------------------------------------------------------------------------- - -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b -mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) - where - g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, - fmap (mapCondTree fa fc fcnd) me) - -mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a -mapTreeConstrs f = mapCondTree id f id - -mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a -mapTreeConds f = mapCondTree id id f - -mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b -mapTreeData f = mapCondTree f id id - --- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for --- clarity. -data DepTestRslt d = DepOk | MissingDeps d - -instance Monoid d => Monoid (DepTestRslt d) where - mempty = DepOk - mappend DepOk x = x - mappend x DepOk = x - mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') - - -data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree - - --- | Try to find a flag assignment that satisfies the constaints of all trees. --- --- Returns either the missing dependencies, or a tuple containing the --- resulting data, the associated dependencies, and the chosen flag --- assignments. --- --- In case of failure, the _smallest_ number of of missing dependencies is --- returned. [XXX: Could also be specified with a function argument.] --- --- XXX: 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 :: Monoid a => - [(FlagName,[Bool])] - -- ^ Domain for each flag name, will be tested in order. - -> OS -- ^ OS as returned by Distribution.System.buildOS - -> Arch -- ^ Arch as returned by Distribution.System.buildArch - -> CompilerId -- ^ Compiler flavour + version - -> [Dependency] -- ^ Additional constraints - -> [CondTree ConfVar [Dependency] a] - -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. - -> Either [Dependency] -- missing dependencies - ([a], [Dependency], FlagAssignment) - -- ^ In the returned dependencies, there will be no duplicates by name -resolveWithFlags dom os arch impl constrs trees checkDeps = - case try dom [] of - Right r -> Right r - Left dbt -> Left $ findShortest dbt - where - extraConstrs = toDepMap constrs - - -- simplify trees by (partially) evaluating all conditions and converting - -- dependencies to dependency maps. - simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . mapTreeConds (fst . simplifyWithSysParams os arch impl)) - trees - - -- version to combine 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. - leftJoin :: DependencyMap -> DependencyMap -> DependencyMap - leftJoin left extra = - DependencyMap $ - M.foldWithKey tightenConstraint (unDependencyMap left) - (unDependencyMap extra) - where tightenConstraint n c l = - case M.lookup n l of - Nothing -> l - Just vr -> M.insert n (IntersectVersionRanges vr c) l - - -- @try@ recursively tries all possible flag assignments in the domain and - -- either succeeds or returns a binary tree with the missing dependencies - -- encountered in each run. Since the tree is constructed lazily, we - -- avoid some computation overhead in the successful case. - try [] flags = - let (depss, as) = unzip - . map (simplifyCondTree (env flags)) - $ simplifiedTrees - deps = fromDepMap $ leftJoin (mconcat depss) - extraConstrs - in case (checkDeps deps, deps) of - (DepOk, ds) -> Right (as, ds, flags) - (MissingDeps mds, _) -> Left (BTN mds) - try ((n, vals):rest) flags = - tryAll $ map (\v -> try rest ((n, v):flags)) vals - - tryAll = foldr mp mz - - -- special version of `mplus' for our local purposes - mp (Left xs) (Left ys) = (Left (BTB xs ys)) - mp (Left _) m@(Right _) = m - mp m@(Right _) _ = m - - -- `mzero' - mz = Left (BTN []) - - env flags flag = (maybe (Left flag) Right . lookup flag) flags - - -- for the error case we inspect our lazy tree of missing dependencies and - -- pick the shortest list of missing dependencies - findShortest (BTN x) = x - findShortest (BTB lt rt) = - let l = findShortest lt - r = findShortest rt - in case (l,r) of - ([], xs) -> xs -- [] is too short - (xs, []) -> xs - ([x], _) -> [x] -- single elem is optimum - (_, [x]) -> [x] - (xs, ys) -> if lazyLengthCmp xs ys - then xs else ys - -- lazy variant of @\xs ys -> length xs <= length ys@ - lazyLengthCmp [] _ = True - lazyLengthCmp _ [] = False - lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys - --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'IntersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map String VersionRange } -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) - deriving (Show, Read) -#else --- The Show/Read instance for Data.Map in ghc-6.4 is useless --- so we have to re-implement it here: -instance Show DependencyMap where - showsPrec d (DependencyMap m) = - showParen (d > 10) (showString "DependencyMap" . shows (M.toList m)) - -instance Read DependencyMap where - readPrec = parens $ R.prec 10 $ do - R.Ident "DependencyMap" <- R.lexP - xs <- R.readPrec - return (DependencyMap (M.fromList xs)) - where parens :: R.ReadPrec a -> R.ReadPrec a - parens p = optional - where - optional = p R.+++ mandatory - mandatory = paren optional - - paren :: R.ReadPrec a -> R.ReadPrec a - paren p = do L.Punc "(" <- R.lexP - x <- R.reset p - L.Punc ")" <- R.lexP - return x - - readListPrec = R.readListPrecDefault -#endif - -instance Monoid DependencyMap where - mempty = DependencyMap M.empty - (DependencyMap a) `mappend` (DependencyMap b) = - DependencyMap (M.unionWith IntersectVersionRanges a b) - -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ fromListWith IntersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] - -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] - -simplifyCondTree :: (Monoid a, Monoid d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) -simplifyCondTree env (CondNode a d ifs) = - foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs - where - simplifyIf (cnd, t, me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> error $ "Environment not defined for all free vars" - --- | Flatten a CondTree. This will resolve the CondTree by taking all --- possible paths into account. Note that since branches represent exclusive --- choices this may not result in a \"sane\" result. -ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) -ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) - where f (_, t, me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) - ------------------------------------------------------------------------------- --- Convert GenericPackageDescription to PackageDescription --- - -data PDTagged = Lib Library | Exe String Executable | PDNull deriving Show - -instance Monoid PDTagged where - mempty = PDNull - PDNull `mappend` x = x - x `mappend` PDNull = x - Lib l `mappend` Lib l' = Lib (l `mappend` l') - Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') - _ `mappend` _ = bug "Cannot combine incompatible tags" - --- | Create a package description with all configurations resolved. --- --- This function takes a `GenericPackageDescription` and several environment --- parameters and tries to generate `PackageDescription` by finding a flag --- assignment that result in satisfiable dependencies. --- --- It takes as inputs a not necessarily complete specifications of flags --- assignments, an optional package index as well as platform parameters. If --- some flags are not assigned explicitly, this function will try to pick an --- assignment that causes this function to succeed. The package index is --- optional since on some platforms we cannot determine which packages have --- been installed before. When no package index is supplied, every dependency --- is assumed to be satisfiable, therefore all not explicitly assigned flags --- will get their default values. --- --- This function will fail if it cannot find a flag assignment that leads to --- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return a /minimum/ --- number of dependencies that could not be satisfied. On success, it will --- return the package description and the full flag assignment chosen. --- -finalizePackageDescription :: - Package pkg - => FlagAssignment -- ^ Explicitly specified flag assignments - -> Maybe (PackageIndex pkg) -- ^ Available dependencies. Pass 'Nothing' if - -- this is unknown. - -> OS -- ^ OS-name - -> Arch -- ^ Arch-name - -> CompilerId -- ^ Compiler + Version - -> [Dependency] -- ^ Additional constraints - -> GenericPackageDescription - -> Either [Dependency] - (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. -finalizePackageDescription userflags mpkgs os arch impl constraints - (GenericPackageDescription pkg flags mlib0 exes0) = - case resolveFlags of - Right ((mlib, exes'), deps, flagVals) -> - Right ( pkg { library = mlib - , executables = exes' - , buildDepends = nub deps - } - , flagVals ) - Left missing -> Left $ nub missing - where - -- Combine lib and exes into one list of @CondTree@s with tagged data - condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) - ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 - - untagRslts = foldr untag (Nothing, []) - where - untag (Lib _) (Just _, _) = bug "Only one library expected" - untag (Lib l) (Nothing, exes) = (Just l, exes) - untag (Exe n e) (mlib, exes) - | any ((== n) . fst) exes = bug "Exe with same name found" - | otherwise = (mlib, exes ++ [(n, e)]) - untag PDNull x = x -- actually this should not happen, but let's be liberal - - resolveFlags = - case resolveWithFlags flagChoices os arch impl constraints condTrees check of - Right (as, ds, fs) -> - let (mlib, exes) = untagRslts as in - Right ( (fmap libFillInDefaults mlib, - map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes), - ds, fs) - Left missing -> Left missing - - flagChoices = map (\(MkFlag n _ d) -> (n, d2c n d)) flags - d2c n b = maybe [b, not b] (\x -> [x]) $ lookup n userflags - --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = if all satisfyDep ds - then DepOk - else MissingDeps $ filter (not . satisfyDep) ds - -- if we don't know which packages are present, we just accept any - -- dependency - satisfyDep = maybe (const True) - (\pkgs -> not . null . PackageIndex.lookupDependency pkgs) - mpkgs - -{- -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 ...). --- --- XXX: One particularly tricky case is defaulting. In the original package --- description, e.g., the source directory might either be the default or a --- certain, explicitly set path. Since defaults are filled in only after the --- package has been resolved and when no explicit value has been set, the --- default path will be missing from the package description returned by this --- function. -flattenPackageDescription :: GenericPackageDescription -> PackageDescription -flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0) = - pkg { library = mlib - , executables = reverse exes - , buildDepends = nub $ ldeps ++ reverse edeps - } - where - (mlib, ldeps) = case mlib0 of - Just lib -> let (l,ds) = ignoreConditions lib in - (Just (libFillInDefaults l), ds) - Nothing -> (Nothing, []) - (exes, edeps) = foldr flattenExe ([],[]) exes0 - flattenExe (n, t) (es, ds) = - let (e, ds') = ignoreConditions t in - ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) - --- This is in fact rather a hack. The original version just overrode the --- default values, however, when adding conditions we had to switch to a --- modifier-based approach. There, nothing is ever overwritten, but only --- joined together. --- --- This is the cleanest way i could think of, that doesn't require --- changing all field parsing functions to return modifiers instead. -libFillInDefaults :: Library -> Library -libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi } - -exeFillInDefaults :: Executable -> Executable -exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi } - -biFillInDefaults :: BuildInfo -> BuildInfo -biFillInDefaults bi = - if null (hsSourceDirs bi) - then bi { hsSourceDirs = [currentDir] } - else bi - -bug :: String -> a -bug msg = error $ msg ++ ". Consider this a bug." diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs deleted file mode 100644 --- a/Distribution/ParseUtils.hs +++ /dev/null @@ -1,636 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ParseUtils --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Stability : alpha --- Portability : portable --- --- Utilities for parsing PackageDescription and InstalledPackageInfo. - - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of the University nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- This module is meant to be local-only to Distribution... - --- #hide -module Distribution.ParseUtils ( - LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, - Field(..), fName, lineNo, - FieldDescr(..), ppField, ppFields, readFields, - parseFilePathQ, parseTokenQ, - parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, - parseOptVersion, parsePackageNameQ, parseVersionRangeQ, - parseTestedWithQ, parseLicenseQ, parseExtensionQ, - parseSepList, parseCommaList, parseOptCommaList, - showFilePath, showToken, showTestedWith, showFreeText, - field, simpleField, listField, commaListField, optsField, liftField, - boolField, parseQuoted, - - UnrecFieldParser, warnUnrec, ignoreUnrec, - ) where - -import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) -import Distribution.License -import Distribution.Version -import Distribution.Package ( parsePackageName, Dependency(..) ) -import Distribution.Compat.ReadP as ReadP hiding (get) -import Distribution.ReadE -import Distribution.Text - ( Text(..) ) -import Distribution.Simple.Utils (intercalate, lowercase) -import Language.Haskell.Extension (Extension) - -import Text.PrettyPrint.HughesPJ hiding (braces) -import Data.Char (isSpace, isUpper, toLower, isAlphaNum, isDigit) -import Data.Maybe (fromMaybe) -import Data.Tree as Tree (Tree(..), flatten) -import System.FilePath (normalise) - --- ----------------------------------------------------------------------------- - -type LineNo = Int - -data PError = AmbigousParse String LineNo - | NoParse String LineNo - | TabsError LineNo - | FromString String (Maybe LineNo) - deriving Show - -data PWarning = PWarning String - | UTFWarning LineNo String - deriving Show - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning msg) = - normalise fpath ++ ": " ++ msg -showPWarning fpath (UTFWarning line fname) = - normalise fpath ++ ":" ++ show line - ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." - -data ParseResult a = ParseFailed PError | ParseOk [PWarning] a - deriving Show - -instance Monad ParseResult where - return x = ParseOk [] x - ParseFailed err >>= _ = ParseFailed err - ParseOk ws x >>= f = case f x of - ParseFailed err -> ParseFailed err - ParseOk ws' x' -> ParseOk (ws'++ws) x' - fail s = ParseFailed (FromString s Nothing) - -catchParseError :: ParseResult a -> (PError -> ParseResult a) - -> ParseResult a -p@(ParseOk _ _) `catchParseError` _ = p -ParseFailed e `catchParseError` k = k e - -parseFail :: PError -> ParseResult a -parseFail = ParseFailed - -runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a -runP line fieldname p s = - case [ x | (x,"") <- results ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - --TODO: what is this double parse thing all about? - -- Can't we just do the all isSpace test the first time? - [] -> case [ x | (x,ys) <- results, all isSpace ys ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - [] -> ParseFailed (NoParse fieldname line) - _ -> ParseFailed (AmbigousParse fieldname line) - _ -> ParseFailed (AmbigousParse fieldname line) - where results = readP_to_S p s - -runE :: LineNo -> String -> ReadE a -> String -> ParseResult a -runE line fieldname p s = - case runReadE p s of - Right a -> ParseOk (utf8Warnings line fieldname s) a - Left e -> syntaxError line ("Parse of field '"++fieldname++"' failed ("++e++"): " ) - -utf8Warnings :: LineNo -> String -> String -> [PWarning] -utf8Warnings line fieldname s = - take 1 [ UTFWarning n fieldname - | (n,l) <- zip [line..] (lines s) - , '\xfffd' `elem` l ] - -locatedErrorMsg :: PError -> (Maybe LineNo, String) -locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") -locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.") -locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") -locatedErrorMsg (FromString s n) = (n, s) - -syntaxError :: LineNo -> String -> ParseResult a -syntaxError n s = ParseFailed $ FromString s (Just n) - -tabsError :: LineNo -> ParseResult a -tabsError ln = ParseFailed $ TabsError ln - -warning :: String -> ParseResult () -warning s = ParseOk [PWarning s] () - --- | Field descriptor. The parameter @a@ parameterizes over where the field's --- value is stored in. -data FieldDescr a - = FieldDescr - { fieldName :: String - , fieldGet :: a -> Doc - , fieldSet :: LineNo -> String -> a -> ParseResult a - -- ^ @fieldSet n str x@ Parses the field value from the given input - -- string @str@ and stores the result in @x@ if the parse was - -- successful. Otherwise, reports an error on line number @n@. - } - -field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a -field name showF readF = - FieldDescr name showF (\line val _st -> runP line name readF val) - --- Lift a field descriptor storing into an 'a' to a field descriptor storing --- into a 'b'. -liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set (FieldDescr name showF parseF) - = FieldDescr name (\b -> showF (get b)) - (\line str b -> do - a <- parseF line str (get b) - return (set a b)) - --- Parser combinator for simple fields. Takes a field name, a pretty printer, --- a parser function, an accessor, and a setter, returns a FieldDescr over the --- compoid structure. -simpleField :: String -> (a -> Doc) -> (ReadP a a) - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleField name showF readF get set - = liftField get set $ field name showF readF - -commaListField :: String -> (a -> Doc) -> (ReadP [a] a) - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListField name showF readF get set = - liftField get set' $ - field name (fsep . punctuate comma . map showF) (parseCommaList readF) - where - set' xs b = set (get b ++ xs) b - -listField :: String -> (a -> Doc) -> (ReadP [a] a) - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listField name showF readF get set = - liftField get set' $ - field name (fsep . map showF) (parseOptCommaList readF) - where - set' xs b = set (get b ++ xs) b - -optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b -optsField name flavor get set = - liftField (fromMaybe [] . lookup flavor . get) - (\opts b -> set (update flavor opts (get b)) b) $ - field name (hsep . map text) - (sepBy parseTokenQ' (munch1 isSpace)) - where - update f opts [] = [(f,opts)] - update f opts ((f',opts'):rest) - | f == f' = (f, opts' ++ opts) : rest - | otherwise = (f',opts') : update f opts rest - --- TODO: this is a bit smelly hack. It's because we want to parse bool fields --- liberally but not accept new parses. We cannot do that with ReadP --- because it does not support warnings. We need a new parser framwork! -boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b -boolField name get set = liftField get set (FieldDescr name showF readF) - where - showF = text . show - readF line str _ - | str == "True" = ParseOk [] True - | str == "False" = ParseOk [] False - | lstr == "true" = ParseOk [caseWarning] True - | lstr == "false" = ParseOk [caseWarning] False - | otherwise = ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." - -ppFields :: a -> [FieldDescr a] -> Doc -ppFields _ [] = empty -ppFields pkg' ((FieldDescr name getter _):flds) = - ppField name (getter pkg') $$ ppFields pkg' flds - -ppField :: String -> Doc -> Doc -ppField name fielddoc = text name <> colon <+> fielddoc - - --- | The type of a function which, given a name-value pair of an --- unrecognized field, and the current structure being built, --- decides whether to incorporate the unrecognized field --- (by returning Just x, where x is a possibly modified version --- of the structure being built), or not (by returning Nothing). -type UnrecFieldParser a = (String,String) -> a -> Maybe a - --- | A default unrecognized field parser which simply returns Nothing, --- i.e. ignores all unrecognized fields, so warnings will be generated. -warnUnrec :: UnrecFieldParser a -warnUnrec _ _ = Nothing - --- | A default unrecognized field parser which silently (i.e. no --- warnings will be generated) ignores unrecognized fields, by --- returning the structure being built unmodified. -ignoreUnrec :: UnrecFieldParser a -ignoreUnrec _ x = Just x - ------------------------------------------------------------------------------- - --- The data type for our three syntactic categories -data Field - = F LineNo String String - -- ^ A regular @: @ field - | Section LineNo String String [Field] - -- ^ A section with a name and possible parameter. The syntactic - -- structure is: - -- - -- @ - -- { - -- * - -- } - -- @ - | IfBlock LineNo String [Field] [Field] - -- ^ A conditional block with an optional else branch: - -- - -- @ - -- if { - -- * - -- } else { - -- * - -- } - -- @ - deriving (Show - ,Eq) -- for testing - -lineNo :: Field -> LineNo -lineNo (F n _ _) = n -lineNo (Section n _ _ _) = n -lineNo (IfBlock n _ _ _) = n - -fName :: Field -> String -fName (F _ n _) = n -fName (Section _ n _ _) = n -fName _ = error "fname: not a field or section" - -readFields :: String -> ParseResult [Field] -readFields input = ifelse - =<< mapM (mkField 0) - =<< mkTree tokens - - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLine . trimLines) ls - --- attach line number and determine indentation -trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] -trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) - | (lineno, l) <- zip [1..] ls - , let (sps, l') = span isSpace l - indent = length sps - hastabs = '\t' `elem` sps - , validLine l' ] - where validLine ('-':'-':_) = False -- Comment - validLine [] = False -- blank line - validLine _ = True - --- | We parse generically based on indent level and braces '{' '}'. To do that --- we split into lines and then '{' '}' tokens and other spans within a line. -data Token = - -- | The 'Line' token is for bits that /start/ a line, eg: - -- - -- > "\n blah blah { blah" - -- - -- tokenises to: - -- - -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] - -- - -- so lines are the only ones that can have nested layout, since they - -- have a known indentation level. - -- - -- eg: we can't have this: - -- - -- > if ... { - -- > } else - -- > other - -- - -- because other cannot nest under else, since else doesn't start a line - -- so cannot have nested layout. It'd have to be: - -- - -- > if ... { - -- > } - -- > else - -- > other - -- - -- but that's not so common, people would normally use layout or - -- brackets not both in a single @if else@ construct. - -- - -- > if ... { foo : bar } - -- > else - -- > other - -- - -- this is ok - Line LineNo Indent HasTabs String - | Span LineNo String -- ^ span in a line, following brackets - | OpenBracket LineNo | CloseBracket LineNo - -type Indent = Int -type HasTabs = Bool - --- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. --- Also trims leading & trailing space on those spans within the line. -tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLine (n0, i, t, l) = case split n0 l of - (Span _ l':ss) -> Line n0 i t l' :ss - cs -> cs - where split _ "" = [] - split n s = case span (\c -> c /='}' && c /= '{') s of - ("", '{' : s') -> OpenBracket n : split n s' - (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') - ("", '}' : s') -> CloseBracket n : split n s' - (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') - (w , _) -> mkspan n w [] - - mkspan n s ss | null s' = ss - | otherwise = Span n s' : ss - where s' = trimTrailing (trimLeading s) - -trimLeading, trimTrailing :: String -> String -trimLeading = dropWhile isSpace -trimTrailing = reverse . dropWhile isSpace . reverse - - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - -type SyntaxTree = Tree (LineNo, HasTabs, String) - --- | Parse the stream of tokens into a tree of them, based on indent \/ layout -mkTree :: [Token] -> ParseResult [SyntaxTree] -mkTree toks = - layout 0 [] toks >>= \(trees, trailing) -> case trailing of - [] -> return trees - OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {" - CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }" - -- the following two should never happen: - Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l - Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l - - --- | Parse the stream of tokens into a tree of them, based on indent --- This parse state expect to be in a layout context, though possibly --- nested within a braces context so we may still encounter closing braces. -layout :: Indent -- ^ indent level of the parent\/previous line - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree], [Token]) - -- ^ collected trees on this level and trailing tokens -layout _ a [] = return (reverse a, []) -layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) -layout i a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,t,l) sub:a) ss' - -layout i a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,False,l) sub:a) ss' - --- look ahead to see if following lines are more indented, giving a sub-tree -layout i a (Line n i' t l:ss) = do - lookahead <- layout (i'+1) [] ss - case lookahead of - ([], _) -> layout i (Node (n,t,l) [] :a) ss - (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' - -layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'" -layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) -layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " - ++ show l - --- | Parse the stream of tokens into a tree of them, based on explicit braces --- This parse state expects to find a closing bracket. -braces :: LineNo -- ^ line of the '{', used for error messages - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree],[Token]) - -- ^ collected trees on this level and trailing tokens -braces m a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,t,l) sub:a) ss' - -braces m a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,False,l) sub:a) ss' - -braces m a (Line n i t l:ss) = do - lookahead <- layout (i+1) [] ss - case lookahead of - ([], _) -> braces m (Node (n,t,l) [] :a) ss - (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' - -braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss -braces _ a (CloseBracket _:ss) = return (reverse a, ss) -braces n _ [] = syntaxError n $ "opening brace '{'" - ++ "has no matching closing brace '}'" -braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" - --- | Convert the parse tree into the Field AST --- Also check for dodgy uses of tabs in indentation. -mkField :: Int -> SyntaxTree -> ParseResult Field -mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n -mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of - ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l - (name, rest) -> case trimLeading rest of - (':':rest') -> do let followingLines = concatMap Tree.flatten ts - tabs = not (null [()| (_,True,_) <- followingLines ]) - if tabs && d >= 1 - then tabsError n - else return $ F n (map toLower name) - (fieldValue rest' followingLines) - rest' -> do ts' <- mapM (mkField (d+1)) ts - return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = - let firstLine' = trimLeading firstLine - followingLines' = map (\(_,_,s) -> stripDot s) followingLines - allLines | null firstLine' = followingLines' - | otherwise = firstLine' : followingLines' - in intercalate "\n" allLines - stripDot "." = "" - stripDot s = s - --- | Convert if/then/else 'Section's to 'IfBlock's -ifelse :: [Field] -> ParseResult [Field] -ifelse [] = return [] -ifelse (Section n "if" cond thenpart - :Section _ "else" as elsepart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | not (null as) = syntaxError n "'else' takes no arguments" - | null elsepart = syntaxError n "'else' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - ep <- ifelse elsepart - fs' <- ifelse fs - return (IfBlock n cond tp ep:fs') -ifelse (Section n "if" cond thenpart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - fs' <- ifelse fs - return (IfBlock n cond tp []:fs') -ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" -ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' - fs''' <- ifelse fs - return (Section n s a fs'' : fs''') -ifelse (f:fs) = do fs' <- ifelse fs - return (f : fs') - ------------------------------------------------------------------------------- - --- |parse a module name -parseModuleNameQ :: ReadP r String -parseModuleNameQ = parseQuoted modu <++ modu - where modu = do - c <- satisfy isUpper - cs <- munch (\x -> isAlphaNum x || x `elem` "_'.") - return (c:cs) - -parseFilePathQ :: ReadP r FilePath -parseFilePathQ = parseTokenQ - -- removed until normalise is no longer broken, was: - -- liftM normalise parseTokenQ - -parseBuildTool :: ReadP r Dependency -parseBuildTool = do name <- parseBuildToolNameQ - skipSpaces - ver <- parseVersionRangeQ <++ return AnyVersion - skipSpaces - return $ Dependency name ver - -parseBuildToolNameQ :: ReadP r String -parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName - --- like parsePackageName but accepts symbols in components -parseBuildToolName :: ReadP r String -parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') - return (intercalate "-" ns) - where component = do - cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then pfail else return cs - --- pkg-config allows versions and other letters in package names, --- eg "gtk+-2.0" is a valid pkg-config package _name_. --- It then has a package version number like 2.10.13 -parsePkgconfigDependency :: ReadP r Dependency -parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") - skipSpaces - ver <- parseVersionRangeQ <++ return AnyVersion - skipSpaces - return $ Dependency name ver - -parsePackageNameQ :: ReadP r String -parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName - -parseVersionRangeQ :: ReadP r VersionRange -parseVersionRangeQ = parseQuoted parse <++ parse - -parseOptVersion :: ReadP r Version -parseOptVersion = parseQuoted ver <++ ver - where ver = parse <++ return noVersion - noVersion = Version{ versionBranch=[], versionTags=[] } - -parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) -parseTestedWithQ = parseQuoted tw <++ tw - where tw = do compiler <- parseCompilerFlavorCompat - skipSpaces - version <- parse <++ return AnyVersion - skipSpaces - return (compiler,version) - -parseLicenseQ :: ReadP r License -parseLicenseQ = parseQuoted parse <++ parse - --- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a --- because the "compat" version of ReadP isn't quite powerful enough. In --- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a --- Hence the trick above to make 'lic' polymorphic. - -parseExtensionQ :: ReadP r Extension -parseExtensionQ = parseQuoted parse <++ parse - -parseHaskellString :: ReadP r String -parseHaskellString = readS_to_P reads - -parseTokenQ :: ReadP r String -parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') - -parseTokenQ' :: ReadP r String -parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) - -parseSepList :: ReadP r b - -> ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseSepList sepr p = sepBy p separator - where separator = skipSpaces >> sepr >> skipSpaces - -parseCommaList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseCommaList = parseSepList (ReadP.char ',') - -parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseOptCommaList = parseSepList (optional (ReadP.char ',')) - -parseQuoted :: ReadP r a -> ReadP r a -parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p - --- -------------------------------------------- --- ** Pretty printing - -showFilePath :: FilePath -> Doc -showFilePath = showToken - -showToken :: String -> Doc -showToken str - | not (any dodgy str) && - not (null str) = text str - | otherwise = text (show str) - where dodgy c = isSpace c || c == ',' - -showTestedWith :: (CompilerFlavor,VersionRange) -> Doc -showTestedWith (compiler, version) = text (show compiler) <+> disp version - --- | Pretty-print free-format text, ensuring that it is vertically aligned, --- and with blank lines replaced by dots for correct re-parsing. -showFreeText :: String -> Doc -showFreeText s = vcat [text (if null l then "." else l) | l <- lines s] diff --git a/Distribution/ReadE.hs b/Distribution/ReadE.hs deleted file mode 100644 --- a/Distribution/ReadE.hs +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ReadE --- Copyright : Jose Iborra 2008 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Simple parsing with failure - -{- Copyright (c) 2007, Jose Iborra -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.ReadE ( - -- * ReadE - ReadE(..), succeedReadE, failReadE, - -- * Projections - parseReadE, readEOrFail, - readP_to_E - ) where - -import Data.Either (either) -import Distribution.Compat.ReadP -import Data.Char ( isSpace ) - --- | Parser with simple error reporting -newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} -type ErrorMsg = String - -instance Functor ReadE where - fmap f (ReadE p) = ReadE $ \txt -> case p txt of - Right a -> Right (f a) - Left err -> Left err - -succeedReadE :: (String -> a) -> ReadE a -succeedReadE f = ReadE (Right . f) - -failReadE :: ErrorMsg -> ReadE a -failReadE = ReadE . const Left - -parseReadE :: ReadE a -> ReadP r a -parseReadE (ReadE p) = do - txt <- look - either fail return (p txt) - -readEOrFail :: ReadE a -> (String -> a) -readEOrFail r = either error id . runReadE r - -readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a -readP_to_E err r = - ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt - , all isSpace s ] - of [] -> Left (err txt) - (p:_) -> Right p diff --git a/Distribution/Setup.hs b/Distribution/Setup.hs deleted file mode 100644 --- a/Distribution/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Distribution.Setup -{-# DEPRECATED "Use module Distribution.Simple.Setup instead" #-} - (module Distribution.Simple.Setup) where - -import Distribution.Simple.Setup diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs deleted file mode 100644 --- a/Distribution/Simple.hs +++ /dev/null @@ -1,534 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Simple build system; basically the interface for --- Distribution.Simple.\* modules. When given the parsed command-line --- args and package information, is able to perform basic commands --- like configure, build, install, register, etc. --- --- 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. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - defaultUserHooks, emptyUserHooks, - -- ** Utils - defaultHookedPackageDesc - ) where - --- local -import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Simple.UserHooks -import Distribution.Package --must not specify imports, since we're exporting moule. -import Distribution.PackageDescription - ( PackageDescription(..), GenericPackageDescription - , updatePackageDescription, hasLibs - , HookedBuildInfo, emptyHookedBuildInfo - , readPackageDescription, readHookedBuildInfo ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Simple.Program - ( ProgramConfiguration, defaultProgramConfiguration, addKnownProgram - , userSpecifyArgs ) -import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Build ( build, makefile ) -import Distribution.Simple.SrcDist ( sdist ) -import Distribution.Simple.Register ( register, unregister, - writeInstalledConfig, - removeRegScripts - ) - -import Distribution.Simple.Configure(getPersistBuildConfig, - maybeGetPersistBuildConfig, - checkPersistBuildConfig, - configure, writePersistBuildConfig) - -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Install (install) -import Distribution.Simple.Haddock (haddock, hscolour) -import Distribution.Simple.Utils - (die, notice, info, warn, setupMessage, chattyTry, - defaultPackageDesc, defaultHookedPackageDesc, - rawSystemExit, cabalVersion ) -import Distribution.Verbosity -import Language.Haskell.Extension -import Distribution.Version -import Distribution.License -import Distribution.Text - ( display ) - --- Base -import System.Environment(getArgs,getProgName) -import System.Directory(removeFile, doesFileExist, - doesDirectoryExist, removeDirectoryRecursive) -import System.Exit - -import Control.Monad (when) -import Data.List (intersperse, unionBy) - --- | 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 :: PackageDescription -> IO () -defaultMainNoRead pkg_descr = - getArgs >>= - defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } - -defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = - case commandsRun globalCommand commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (concat (intersperse "\n" errs)) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ display cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ display cabalVersion - - progs = allPrograms hooks - commands = - [configureCommand progs `commandAddAction` configureAction hooks - ,buildCommand progs `commandAddAction` buildAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ,makefileCommand `commandAddAction` makefileAction hooks - ] - --- | Combine the programs in the given hooks with the programs built --- into cabal. -allPrograms :: UserHooks - -> ProgramConfiguration -- combine defaults w/ user programs -allPrograms h = foldl (flip addKnownProgram) - defaultProgramConfiguration - (hookedPrograms h) - --- | 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 () -configureAction hooks flags args = do - let distPref = fromFlag $ configDistPref flags - pbi <- preConf hooks args flags - - (mb_pd_file, pkg_descr0) <- confPkgDescr - - -- get_pkg_descr (configVerbosity flags') - --let pkg_descr = updatePackageDescription pbi pkg_descr0 - let epkg_descr = (pkg_descr0, pbi) - - --(warns, ers) <- sanityCheckPackage pkg_descr - --errorOut (configVerbosity flags') warns ers - - localbuildinfo0 <- confHook hooks epkg_descr flags - - -- remember the .cabal filename if we know it - let localbuildinfo = localbuildinfo0{ pkgDescrFile = mb_pd_file } - writePersistBuildConfig distPref localbuildinfo - - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags pkg_descr localbuildinfo - where - verbosity = fromFlag (configVerbosity flags) - confPkgDescr :: IO (Maybe FilePath, - Either GenericPackageDescription - PackageDescription) - confPkgDescr = do - mdescr <- readDesc hooks - case mdescr of - Just descr -> return (Nothing, Right descr) - Nothing -> do - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - return (Just pdfile, Left ppd) - -buildAction :: UserHooks -> BuildFlags -> Args -> IO () -buildAction hooks flags args = do - let distPref = fromFlag $ buildDistPref flags - lbi <- getBuildConfigIfUpToDate distPref - let progs = foldl userSpecifyArgs' - (withPrograms lbi) (buildProgramArgs flags) - where userSpecifyArgs' conf (prog, args') = - userSpecifyArgs prog args' conf - hookedAction preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags args - -makefileAction :: UserHooks -> MakefileFlags -> Args -> IO () -makefileAction hooks flags args - = do let distPref = fromFlag $ makefileDistPref flags - hookedAction preMakefile makefileHook postMakefile - (getBuildConfigIfUpToDate distPref) - hooks flags args - -hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction hooks flags args - = do let distPref = fromFlag $ hscolourDistPref flags - hookedAction preHscolour hscolourHook postHscolour - (getBuildConfigIfUpToDate distPref) - hooks flags args - -haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () -haddockAction hooks flags args - = do let distPref = fromFlag $ haddockDistPref flags - hookedAction preHaddock haddockHook postHaddock - (getBuildConfigIfUpToDate distPref) - hooks flags args - -cleanAction :: UserHooks -> CleanFlags -> Args -> IO () -cleanAction hooks flags args = do - let distPref = fromFlag $ cleanDistPref flags - pbi <- preClean hooks args flags - - mlbi <- maybeGetPersistBuildConfig distPref - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - let pkg_descr0 = flattenPackageDescription ppd - let pkg_descr = updatePackageDescription pbi pkg_descr0 - - cleanHook hooks pkg_descr mlbi hooks flags - postClean hooks args flags pkg_descr mlbi - where verbosity = fromFlag (cleanVerbosity flags) - -copyAction :: UserHooks -> CopyFlags -> Args -> IO () -copyAction hooks flags args - = do let distPref = fromFlag $ copyDistPref flags - hookedAction preCopy copyHook postCopy - (getBuildConfigIfUpToDate distPref) - hooks flags args - -installAction :: UserHooks -> InstallFlags -> Args -> IO () -installAction hooks flags args - = do let distPref = fromFlag $ installDistPref flags - hookedAction preInst instHook postInst - (getBuildConfigIfUpToDate distPref) - hooks flags args - -sdistAction :: UserHooks -> SDistFlags -> Args -> IO () -sdistAction hooks flags args = do - let distPref = fromFlag $ sDistDistPref flags - pbi <- preSDist hooks args flags - - mlbi <- maybeGetPersistBuildConfig distPref - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - let pkg_descr0 = flattenPackageDescription ppd - let pkg_descr = updatePackageDescription pbi pkg_descr0 - - sDistHook hooks pkg_descr mlbi hooks flags - postSDist hooks args flags pkg_descr mlbi - where verbosity = fromFlag (sDistVerbosity flags) - -testAction :: UserHooks -> TestFlags -> Args -> IO () -testAction hooks flags args = do - let distPref = fromFlag $ testDistPref flags - localbuildinfo <- getBuildConfigIfUpToDate distPref - let pkg_descr = localPkgDescr localbuildinfo - runTests hooks args False pkg_descr localbuildinfo - -registerAction :: UserHooks -> RegisterFlags -> Args -> IO () -registerAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags - hookedAction preReg regHook postReg - (getBuildConfigIfUpToDate distPref) - hooks flags args - -unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags - hookedAction preUnreg unregHook postUnreg - (getBuildConfigIfUpToDate distPref) - hooks flags args - -hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - localbuildinfo <- get_build_config - let pkg_descr0 = localPkgDescr localbuildinfo - --pkg_descr0 <- get_pkg_descr (get_verbose flags) - let pkg_descr = updatePackageDescription pbi pkg_descr0 - -- XXX: should we write the modified package descr back to the - -- localbuildinfo? - cmd_hook hooks pkg_descr localbuildinfo hooks flags - post_hook hooks args flags pkg_descr localbuildinfo - -getBuildConfigIfUpToDate :: FilePath -> IO LocalBuildInfo -getBuildConfigIfUpToDate distPref = do - lbi <- getPersistBuildConfig distPref - case pkgDescrFile lbi of - Nothing -> return () - Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file - return lbi - --- -------------------------------------------------------------------------- --- Cleaning - -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do - let distPref = fromFlag $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing - - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) - - -- these live in the top level dir so must be removed separately - removeRegScripts - - -- Any extra files the user wants to remove - mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) - - -- If the user wanted to save the config, write it back - maybe (return ()) (writePersistBuildConfig distPref) maybeConfig - - where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir then removeDirectoryRecursive fname - else if isFile then removeFile fname - else return () - verbosity = fromFlag (cleanVerbosity flags) - --- -------------------------------------------------------------------------- --- Default hooks - --- | Hooks that correspond to a plain instantiation of the --- \"simple\" build system -simpleUserHooks :: UserHooks -simpleUserHooks = - emptyUserHooks { - confHook = configure, - buildHook = defaultBuildHook, - makefileHook = defaultMakefileHook, - copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params - instHook = defaultInstallHook, - sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), - cleanHook = \p _ _ f -> clean p f, - hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, - haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f - } - --- | Basic autoconf 'UserHooks': --- --- * on non-Windows systems, '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. - --- FIXME: do something sensible for windows, or do nothing in postConf. - -defaultUserHooks :: UserHooks -defaultUserHooks = autoconfUserHooks { - confHook = \pkg flags -> do - let verbosity = fromFlag (configVerbosity flags) - warn verbosity $ - "defaultUserHooks in Setup script is deprecated." - confHook autoconfUserHooks pkg flags, - postConf = oldCompatPostConf - } - -- This is the annoying old version that only runs configure if it exists. - -- It's here for compatability with existing Setup.hs scripts. See: - -- http://hackage.haskell.org/trac/hackage/ticket/165 - where oldCompatPostConf args flags _ _ - = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args - confExists <- doesFileExist "configure" - when confExists $ - rawSystemExit verbosity "sh" $ - "configure" : configureArgs backwardsCompatHack flags - backwardsCompatHack = True - -autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHook buildVerbosity, - preMakefile = readHook makefileVerbosity, - preClean = readHook cleanVerbosity, - preCopy = readHook copyVerbosity, - preInst = readHook installVerbosity, - preHscolour = readHook hscolourVerbosity, - preHaddock = readHook haddockVerbosity, - preReg = readHook regVerbosity, - preUnreg = readHook regVerbosity - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () - defaultPostConf args flags _ _ - = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args - confExists <- doesFileExist "configure" - if confExists - then rawSystemExit verbosity "sh" $ - "configure" - : configureArgs backwardsCompatHack flags - else die "configure script not found." - backwardsCompatHack = False - - readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity a flags = do - noExtraFlags a - maybe_infoFile <- defaultHookedPackageDesc - case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo - Just infoFile -> do - let verbosity = fromFlag (get_verbosity flags) - info verbosity $ "Reading parameters from " ++ infoFile - readHookedBuildInfo verbosity infoFile - -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do - install pkg_descr localbuildinfo defaultCopyFlags { - copyDest' = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ - register pkg_descr localbuildinfo defaultRegisterFlags { - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = do - let distPref = fromFlag $ buildDistPref flags - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - when (hasLibs pkg_descr) $ - writeInstalledConfig distPref pkg_descr localbuildinfo False Nothing - -defaultMakefileHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> MakefileFlags -> IO () -defaultMakefileHook pkg_descr localbuildinfo hooks flags = do - let distPref = fromFlag $ makefileDistPref flags - makefile pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - when (hasLibs pkg_descr) $ - writeInstalledConfig distPref pkg_descr localbuildinfo False Nothing - -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage verbosity - "Package contains no library to register:" (packageId pkg_descr) - where verbosity = fromFlag (regVerbosity flags) diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs deleted file mode 100644 --- a/Distribution/Simple/Build.hs +++ /dev/null @@ -1,346 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Invokes the "Distribution.Compiler"s to build the library and --- executables in this package. - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Build ( - build, makefile, initialBuildSteps - ) where - -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), - Executable(..), Library(..) ) -import Distribution.Package - ( Package(..), packageName, packageVersion ) -import Distribution.Simple.Setup ( CopyDest(..), BuildFlags(..), - MakefileFlags(..), fromFlag ) -import Distribution.Simple.PreProcess ( preprocessSources, PPSuffixHandler ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), - InstallDirs(..), absoluteInstallDirs, - prefixRelativeInstallDirs ) -import Distribution.Simple.BuildPaths ( autogenModuleName ) -import Distribution.Simple.Configure - ( localBuildInfoFile ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, die, setupMessage, writeUTF8File ) -import Distribution.System - -import System.FilePath ( (), pathSeparator ) - -import Data.Maybe ( maybeToList, fromJust, isNothing ) -import Control.Monad ( unless, when ) -import System.Directory ( getModificationTime, doesFileExist ) - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.JHC as JHC -import qualified Distribution.Simple.NHC as NHC -import qualified Distribution.Simple.Hugs as Hugs - -import Distribution.PackageDescription (hasLibs) -import Distribution.Verbosity -import Distribution.Text - ( display ) - --- ----------------------------------------------------------------------------- --- |Build the libraries and executables in this package. - -build :: PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> BuildFlags -- ^Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling - -> IO () -build pkg_descr lbi flags suffixes = do - let distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - initialBuildSteps distPref pkg_descr lbi verbosity suffixes - setupMessage verbosity "Building" (packageId pkg_descr) - case compilerFlavor (compiler lbi) of - GHC -> GHC.build pkg_descr lbi verbosity - JHC -> JHC.build pkg_descr lbi verbosity - Hugs -> Hugs.build pkg_descr lbi verbosity - NHC -> NHC.build pkg_descr lbi verbosity - _ -> die ("Building is not supported with this compiler.") - -makefile :: PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> MakefileFlags -- ^Flags that the user passed to makefile - -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling - -> IO () -makefile pkg_descr lbi flags suffixes = do - let distPref = fromFlag (makefileDistPref flags) - verbosity = fromFlag (makefileVerbosity flags) - initialBuildSteps distPref pkg_descr lbi verbosity suffixes - when (not (hasLibs pkg_descr)) $ - die ("Makefile is only supported for libraries, currently.") - setupMessage verbosity "Generating Makefile" (packageId pkg_descr) - case compilerFlavor (compiler lbi) of - GHC -> GHC.makefile pkg_descr lbi flags - _ -> die ("Generating a Makefile is not supported for this compiler.") - - -initialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> Verbosity -- ^The verbosity to use - -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling - -> IO () -initialBuildSteps distPref pkg_descr lbi verbosity suffixes = do - -- check that there's something to build - let buildInfos = - map libBuildInfo (maybeToList (library pkg_descr)) ++ - map buildInfo (executables pkg_descr) - unless (any buildable buildInfos) $ do - let name = display (packageId pkg_descr) - die ("Package " ++ name ++ " can't be built on this system.") - - createDirectoryIfMissingVerbose verbosity True (buildDir lbi) - - -- construct and write the Paths_.hs file - createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) - buildPathsModule distPref pkg_descr lbi - - preprocessSources pkg_descr lbi False verbosity suffixes - --- ------------------------------------------------------------ --- * Building Paths_.hs --- ------------------------------------------------------------ - --- The directory in which we put auto-generated modules -autogenModulesDir :: LocalBuildInfo -> String -autogenModulesDir lbi = buildDir lbi "autogen" - -buildPathsModule :: FilePath -> PackageDescription -> LocalBuildInfo -> IO () -buildPathsModule distPref pkg_descr lbi = - let pragmas - | absolute || isHugs = "" - | otherwise = - "{-# LANGUAGE ForeignFunctionInterface #-}\n" ++ - "{-# OPTIONS_GHC -fffi #-}\n"++ - "{-# OPTIONS_JHC -fffi #-}\n" - - foreign_imports - | absolute = "" - | isHugs = "import System.Environment\n" - | otherwise = - "import Foreign\n"++ - "import Foreign.C\n" - - header = - pragmas++ - "module " ++ paths_modulename ++ " (\n"++ - "\tversion,\n"++ - "\tgetBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ - "\tgetDataFileName\n"++ - "\t) where\n"++ - "\n"++ - foreign_imports++ - "import Data.Version (Version(..))\n"++ - "import System.Environment (getEnv)"++ - "\n"++ - "\nversion :: Version"++ - "\nversion = " ++ show (packageVersion pkg_descr)++ - "\n" - - body - | absolute = - "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ - "\nbindir = " ++ show flat_bindir ++ - "\nlibdir = " ++ show flat_libdir ++ - "\ndatadir = " ++ show flat_datadir ++ - "\nlibexecdir = " ++ show flat_libexecdir ++ - "\n"++ - "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ - "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ - "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ - "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir ++ "++path_sep++" ++ name)\n" - | otherwise = - "\nprefix, bindirrel :: FilePath" ++ - "\nprefix = " ++ show flat_prefix ++ - "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ - "\n\n"++ - "getBinDir :: IO FilePath\n"++ - "getBinDir = getPrefixDirRel bindirrel\n\n"++ - "getLibDir :: IO FilePath\n"++ - "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ - "getDataDir :: IO FilePath\n"++ - "getDataDir = "++ mkGetEnvOr "datadir" - (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ - "getLibexecDir :: IO FilePath\n"++ - "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_stuff++ - "\n"++ - filename_stuff - in do btime <- getModificationTime (localBuildInfoFile distPref) - exists <- doesFileExist paths_filepath - ptime <- if exists - then getModificationTime paths_filepath - else return btime - if btime >= ptime - then writeUTF8File paths_filepath (header++body) - else return () - where - InstallDirs { - prefix = flat_prefix, - bindir = flat_bindir, - libdir = flat_libdir, - datadir = flat_datadir, - libexecdir = flat_libexecdir - } = absoluteInstallDirs pkg_descr lbi NoCopyDest - InstallDirs { - bindir = flat_bindirrel, - libdir = flat_libdirrel, - datadir = flat_datadirrel, - libexecdir = flat_libexecdirrel, - progdir = flat_progdirrel - } = prefixRelativeInstallDirs pkg_descr lbi - - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir - - mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++ - " (\\_ -> "++expr++")" - where var' = packageName pkg_descr ++ "_" ++ var - - -- In several cases we cannot make relocatable installations - absolute = - hasLibs pkg_descr -- we can only make progs relocatable - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) - - supportsRelocatableProgs Hugs = True - supportsRelocatableProgs GHC = case buildOS of - Windows -> True - _ -> False - supportsRelocatableProgs _ = False - - paths_modulename = autogenModuleName pkg_descr - paths_filename = paths_modulename ++ ".hs" - paths_filepath = autogenModulesDir lbi paths_filename - - isHugs = compilerFlavor (compiler lbi) == Hugs - get_prefix_stuff - | isHugs = "progdirrel :: String\n"++ - "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ - get_prefix_hugs - | otherwise = get_prefix_win32 - - path_sep = show [pathSeparator] - -get_prefix_win32 :: String -get_prefix_win32 = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = do \n"++ - " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++ - " buf <- mallocArray len\n"++ - " ret <- getModuleFileName nullPtr buf len\n"++ - " if ret == 0 \n"++ - " then do free buf;\n"++ - " return (prefix `joinFileName` dirRel)\n"++ - " else do exePath <- peekCString buf\n"++ - " free buf\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ - "\n"++ - "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++ - " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n" - -get_prefix_hugs :: String -get_prefix_hugs = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = do\n"++ - " mainPath <- getProgName\n"++ - " let (progPath,_) = splitFileName mainPath\n"++ - " let (progdir,_) = splitFileName progPath\n"++ - " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" - -filename_stuff :: String -filename_stuff = - "minusFileName :: FilePath -> String -> FilePath\n"++ - "minusFileName dir \"\" = dir\n"++ - "minusFileName dir \".\" = dir\n"++ - "minusFileName dir suffix =\n"++ - " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ - "\n"++ - "joinFileName :: String -> String -> FilePath\n"++ - "joinFileName \"\" fname = fname\n"++ - "joinFileName \".\" fname = fname\n"++ - "joinFileName dir \"\" = dir\n"++ - "joinFileName dir fname\n"++ - " | isPathSeparator (last dir) = dir++fname\n"++ - " | otherwise = dir++pathSeparator:fname\n"++ - "\n"++ - "splitFileName :: FilePath -> (String, String)\n"++ - "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ - " where\n"++ - " (path,drive) = case p of\n"++ - " (c:':':p') -> (reverse p',[':',c])\n"++ - " _ -> (reverse p ,\"\")\n"++ - " (fname,path1) = break isPathSeparator path\n"++ - " path2 = case path1 of\n"++ - " [] -> \".\"\n"++ - " [_] -> path1 -- don't remove the trailing slash if \n"++ - " -- there is only one character\n"++ - " (c:path') | isPathSeparator c -> path'\n"++ - " _ -> path1\n"++ - "\n"++ - "pathSeparator :: Char\n"++ - (case buildOS of - Windows -> "pathSeparator = '\\\\'\n" - _ -> "pathSeparator = '/'\n") ++ - "\n"++ - "isPathSeparator :: Char -> Bool\n"++ - (case buildOS of - Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" - _ -> "isPathSeparator c = c == '/'\n") diff --git a/Distribution/Simple/BuildPaths.hs b/Distribution/Simple/BuildPaths.hs deleted file mode 100644 --- a/Distribution/Simple/BuildPaths.hs +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.BuildPaths --- Copyright : Isaac Jones 2003-2004, --- Duncan Coutts 2008 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- A bunch of dirs, paths and file names used for intermediate build steps. --- - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.BuildPaths ( - defaultDistPref, srcPref, - hscolourPref, haddockPref, - autogenModulesDir, - - autogenModuleName, - haddockName, - - mkLibName, - mkProfLibName, - mkSharedLibName, - - exeExtension, - objExtension, - dllExtension, - - ) where - - -import System.FilePath (FilePath, (), (<.>)) - -import Distribution.Package - ( PackageIdentifier, packageName ) -import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.PackageDescription (PackageDescription) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) -import Distribution.Simple.Setup (defaultDistPref) -import Distribution.Text - ( display ) -import Distribution.System (OS(..), buildOS) - --- --------------------------------------------------------------------------- --- Build directories and files - -srcPref :: FilePath -> FilePath -srcPref distPref = distPref "src" - -hscolourPref :: FilePath -> PackageDescription -> FilePath -hscolourPref = haddockPref - -haddockPref :: FilePath -> PackageDescription -> FilePath -haddockPref distPref pkg_descr - = distPref "doc" "html" packageName pkg_descr - --- |The directory in which we put auto-generated modules -autogenModulesDir :: LocalBuildInfo -> String -autogenModulesDir lbi = buildDir lbi "autogen" - - --- |The name of the auto-generated module associated with a package -autogenModuleName :: PackageDescription -> String -autogenModuleName pkg_descr = - "Paths_" ++ map fixchar (packageName pkg_descr) - where fixchar '-' = '_' - fixchar c = c - -haddockName :: PackageDescription -> FilePath -haddockName pkg_descr = packageName pkg_descr <.> "haddock" - --- --------------------------------------------------------------------------- --- Library file names - -mkLibName :: PackageIdentifier -> String -mkLibName lib = "libHS" ++ display lib <.> "a" - -mkProfLibName :: PackageIdentifier -> String -mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a" - --- Implement proper name mangling for dynamical shared objects --- libHS- --- e.g. libHSbase-2.1-ghc6.6.1.so -mkSharedLibName :: PackageIdentifier -> CompilerId -> String -mkSharedLibName lib (CompilerId compilerFlavor compilerVersion) - = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension - where comp = display compilerFlavor ++ display compilerVersion - --- ------------------------------------------------------------ --- * Platform file extensions --- ------------------------------------------------------------ - --- ToDo: This should be determined via autoconf (AC_EXEEXT) --- | Extension for executable files --- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) -exeExtension :: String -exeExtension = case buildOS of - Windows -> "exe" - _ -> "" - --- ToDo: This should be determined via autoconf (AC_OBJEXT) --- | Extension for object files. For GHC and NHC the extension is @\"o\"@. --- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler. -objExtension :: String -objExtension = "o" - --- | Extension for dynamically linked (or shared) libraries --- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) -dllExtension :: String -dllExtension = case buildOS of - Windows -> "dll" - OSX -> "dylib" - _ -> "so" diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs deleted file mode 100644 --- a/Distribution/Simple/Command.hs +++ /dev/null @@ -1,527 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Command --- Copyright : Duncan Coutts 2007 --- --- Maintainer : Duncan Coutts --- Stability : alpha --- Portability : portable --- --- Explanation: Data types and parser for the standard command-line --- setup. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Command ( - - -- * Command interface - CommandUI(..), - commandShowOptions, - - -- ** Constructing commands - ShowOrParseArgs(..), - makeCommand, - - -- ** Associating actions with commands - Command, - commandAddAction, - noExtraFlags, - - -- ** Running commands - CommandParse(..), - commandsRun, - --- * Option Fields - OptionField(..), Name, - --- ** Constructing Option Fields - option, multiOption, - --- ** Liftings & Projections - liftOption, viewAsFieldDescr, - --- * Option Descriptions - OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, - --- ** OptDescr 'smart' constructors - MkOptDescr, - reqArg, reqArg', optArg, optArg', noArg, - boolOpt, boolOpt', choiceOpt, choiceOptFromEnum - - ) where - -import Control.Monad -import Data.Char (isAlpha, toLower) -import Data.List (sortBy) -import Data.Maybe -import Data.Monoid -import qualified Distribution.GetOpt as GetOpt -import Distribution.Text - ( Text(disp, parse) ) -import Distribution.ParseUtils -import Distribution.ReadE -import Distribution.Simple.Utils (die, intercalate) -import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty) - -data CommandUI flags = CommandUI { - -- | The name of the command as it would be entered on the command line. - -- For example @\"build\"@. - commandName :: String, - -- | A short, one line description of the command to use in help texts. - commandSynopsis :: String, - -- | The useage line summary for this command - commandUsage :: String -> String, - -- | Additional explanation of the command to use in help texts. - commandDescription :: Maybe (String -> String), - -- | Initial \/ empty flags - commandDefaultFlags :: flags, - -- | All the Option fields for this command - commandOptions :: ShowOrParseArgs -> [OptionField flags] - } - -data ShowOrParseArgs = ShowArgs | ParseArgs - -type Name = String -type Description = String - --- | We usually have a datatype for storing configuration values, where --- every field stores a configuration option, and the user sets --- the value either via command line flags or a configuration file. --- An individual OptionField models such a field, and we usually --- build a list of options associated to a configuration datatype. -data OptionField a = OptionField { - optionName :: Name, - optionDescr :: [OptDescr a] } - --- | An OptionField takes one or more OptDescrs, describing the command line interface for the field. -data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String]) - | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String]) - | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] - | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) - --- | Short command line option strings -type SFlags = [Char] --- | Long command line option strings -type LFlags = [String] -type OptFlags = (SFlags,LFlags) -type ArgPlaceHolder = String - - --- | Create an option taking a single OptDescr. --- No explicit Name is given for the Option, the name is the first LFlag given. -option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a -option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] -option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag" - --- | Create an option taking several OptDescrs. --- You will have to give the flags and description individually to the OptDescr constructor. -multiOption :: Name -> get -> set - -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description. - -> OptionField a -multiOption n get set args = OptionField n [arg get set | arg <- args] - -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a - --- | Create a string-valued command line interface. -reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -reqArg ad mkflag showflag sf lf d get set = - ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get) - --- | Create a string-valued command line interface with a default value. -optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg ad mkflag def showflag sf lf d get set = - OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (\b -> set (get b `mappend` def) b) - (showflag . get) - --- | (String -> a) variant of "reqArg" -reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -reqArg' ad mkflag showflag = - reqArg ad (succeedReadE mkflag) showflag - --- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg' ad mkflag showflag = - optArg ad (succeedReadE (mkflag . Just)) def showflag - where def = mkflag Nothing - -noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a -noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d - -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt g s sfT sfF _sf _lf@(n:_) d get set = - BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) -boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable" - -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) - --- | create a Choice option -choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a -choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts - where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] - --- | create a Choice option out of an enumeration type. --- As long flags, the Show output is used. As short flags, the first character --- which does not conflict with a previous one is used. -choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a -choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d') - | (x, sf) <- sflags' - , let d' = d ++ show x] - _sf _lf d get - where sflags' = foldl f [] [firstOne..] - f prev x = let prevflags = concatMap snd prev in - prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf - , toLower sf `notElem` prevflags] - firstOne = minBound `asTypeOf` get undefined - -commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] -commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) - -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] -viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa - where - optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] - where set' = readEOrFail set - optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = - [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = def - set' (Just txt) = readEOrFail set txt - optDescrToGetOpt (ChoiceOpt alts) = - [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] - optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] - --- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one. -viewAsFieldDescr :: OptionField a -> FieldDescr a -viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n dd) = FieldDescr n get set - where optDescr = head $ sortBy cmp dd - ReqArg{} `cmp` ReqArg{} = EQ - ReqArg{} `cmp` _ = GT - BoolOpt{} `cmp` ReqArg{} = LT - BoolOpt{} `cmp` BoolOpt{} = EQ - BoolOpt{} `cmp` _ = GT - ChoiceOpt{} `cmp` ReqArg{} = LT - ChoiceOpt{} `cmp` BoolOpt{} = LT - ChoiceOpt{} `cmp` ChoiceOpt{} = EQ - ChoiceOpt{} `cmp` _ = GT - OptArg{} `cmp` OptArg{} = EQ - OptArg{} `cmp` _ = LT - get t = case optDescr of - ReqArg _ _ _ _ ppr -> - (cat . punctuate comma . map text . ppr) t - OptArg _ _ _ _ _ ppr -> - case ppr t of - [] -> empty - (Nothing : _) -> text "True" - (Just a : _) -> text a - ChoiceOpt alts -> - fromMaybe empty $ listToMaybe - [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] - BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t - set line val a = - case optDescr of - ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val - -- We parse for a single value instead of a list, - -- as one can't really implement parseList :: ReadE a -> ReadE [a] - -- with the current ReadE definition - ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of - Just f -> return (f a) - _ -> syntaxError line val - BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val - OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far, - -- so we avoid future surprises by not implementing it. - error "Command.optionToFieldDescr: feature not implemented" - -getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) -getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts - , lf == val] - -getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" - -getCurrentChoice :: OptDescr a -> a -> [String] -getCurrentChoice (ChoiceOpt alts) a = - [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] - -getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - - -liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b -liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} - - -liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b -liftOptDescr get' set' (ChoiceOpt opts) = - ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) - | (d, ff, set, get) <- opts] - -liftOptDescr get' set' (OptArg d ff ad set def get) = - OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get') - -liftOptDescr get' set' (ReqArg d ff ad set get) = - ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') - -liftOptDescr get' set' (BoolOpt d ffT ffF set get) = - BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') - -liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b -liftSet get' set' set x = set' (set $ get' x) x - --- | Show flags in the standard long option command line format -commandShowOptions :: CommandUI flags -> flags -> [String] -commandShowOptions command v = concat - [ showOptDescr v od | o <- commandOptions command ParseArgs - , od <- optionDescr o] - where - showOptDescr :: a -> OptDescr a -> [String] - showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled) - = case enabled x of - Nothing -> [] - Just True -> ["--" ++ lfT] - Just False -> ["--" ++ lfF] - showOptDescr x c@ChoiceOpt{} - = ["--" ++ val | val <- getCurrentChoice c x] - showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) - = [ "--"++lf++"="++flag - | flag <- showflag x ] - showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) - = [ case flag of - Just s -> "--"++lf++"="++s - Nothing -> "--"++lf - | flag <- showflag x ] - showOptDescr _ _ - = error "Distribution.Simple.Command.showOptDescr: unreachable" - - -commandListOptions :: CommandUI flags -> [String] -commandListOptions command = - concatMap listOption $ - addCommonFlags ShowArgs $ -- This is a slight hack, we don't want - -- "--list-options" showing up in the - -- list options output, so use ShowArgs - commandGetOpts ShowArgs command - where - listOption (GetOpt.Option shortNames longNames _ _) = - [ "-" ++ [name] | name <- shortNames ] - ++ [ "--" ++ name | name <- longNames ] - --- | The help text for this command with descriptions of all the options. -commandHelp :: CommandUI flags -> String -> String -commandHelp command pname = - commandUsage command pname - ++ (GetOpt.usageInfo "" - . addCommonFlags ShowArgs - $ commandGetOpts ShowArgs command) - ++ case commandDescription command of - Nothing -> "" - Just desc -> '\n': desc pname - --- | Make a Command from standard 'GetOpt' options. -makeCommand :: String -- ^ name - -> String -- ^ short description - -> Maybe (String -> String) -- ^ long description - -> flags -- ^ initial\/empty flags - -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options - -> CommandUI flags -makeCommand name shortDesc longDesc defaultFlags options = - CommandUI { - commandName = name, - commandSynopsis = shortDesc, - commandDescription = longDesc, - commandUsage = usage, - commandDefaultFlags = defaultFlags, - commandOptions = options - } - where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" - --- | Common flags that apply to every command -data CommonFlag = HelpFlag | ListOptionsFlag - -commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] -commonFlags showOrParseArgs = case showOrParseArgs of - ShowArgs -> [help] - ParseArgs -> [help, list] - where - help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) - "Show this help text" - helpShortFlags = case showOrParseArgs of - ShowArgs -> ['h'] - ParseArgs -> ['h', '?'] - list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) - "Print a list of command line flags" - -addCommonFlags :: ShowOrParseArgs - -> [GetOpt.OptDescr a] - -> [GetOpt.OptDescr (Either CommonFlag a)] -addCommonFlags showOrParseArgs options = - map (fmapOptDesc Left) (commonFlags showOrParseArgs) - ++ map (fmapOptDesc Right) options - where fmapOptDesc f (GetOpt.Option s l d m) = - GetOpt.Option s l (fmapArgDesc f d) m - fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) - fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d - fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d - - -commandParseArgs :: CommandUI flags -> Bool -> [String] - -> CommandParse (flags -> flags, [String]) -commandParseArgs command ordered args = - let options = addCommonFlags ParseArgs - $ commandGetOpts ParseArgs command - order | ordered = GetOpt.RequireOrder - | otherwise = GetOpt.Permute - in case GetOpt.getOpt order options args of - (flags, _, _) - | not (null [ () | Left ListOptionsFlag <- flags ]) - -> CommandList (commandListOptions command) - | not (null [ () | Left HelpFlag <- flags ]) - -> CommandHelp (commandHelp command) - (flags, opts, []) -> CommandReadyToGo (accumFlags flags , opts) - (_, _, errs) -> CommandErrors errs - - where -- Note: It is crucial to use reverse function composition here or to - -- reverse the flags here as we want to process the flags left to right - -- but data flow in function compsition is right to left. - accumFlags flags = foldr (flip (.)) id [ f | Right f <- 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 f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - - -data Command action = Command String String ([String] -> CommandParse action) - -commandAddAction :: Monoid flags - => CommandUI flags - -> (flags -> [String] -> action) - -> Command action -commandAddAction command action = - Command (commandName command) - (commandSynopsis command) - (fmap (uncurry applyDefaultArgs) - . commandParseArgs command False) - - where applyDefaultArgs mkflags args = - let flags = commandDefaultFlags command - `mappend` mkflags mempty - in action flags args - -commandsRun :: CommandUI a - -> [Command action] - -> [String] - -> CommandParse (a, CommandParse action) -commandsRun globalCommand commands args = - case commandParseArgs globalCommand' True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs - CommandReadyToGo (mkflags, args') -> case args' of - ("help":cmdArgs) -> handleHelpCommand cmdArgs - (name:cmdArgs) -> case lookupCommand name of - [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs) - _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) - - where - lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands' - , cname'==cname ] - noCommand = CommandErrors ["no command given (try --help)\n"] - badCommand cname = CommandErrors ["unrecognised command: " ++ cname - ++ " (try --help)\n"] - commands' = commands ++ [commandAddAction helpCommandUI undefined] - commandNames = [ name | Command name _ _ <- commands' ] - globalCommand' = globalCommand { - commandUsage = \pname -> - "Usage: " ++ pname ++ " [GLOBAL FLAGS]\n" - ++ " or: " ++ pname ++ " COMMAND [FLAGS]\n\n" - ++ "Global flags:", - commandDescription = Just $ \pname -> - "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ description - | Command name description _ <- commands' ] - ++ case commandDescription globalCommand of - Nothing -> "" - Just desc -> '\n': desc pname - } - where maxlen = maximum [ length name | Command name _ _ <- commands' ] - align str = str ++ replicate (maxlen - length str) ' ' - - -- A bit of a hack: support "prog help" as a synonym of "prog --help" - -- furthermore, support "prog help command" as "prog command --help" - handleHelpCommand cmdArgs = - case commandParseArgs helpCommandUI True cmdArgs of - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_,[]) -> CommandHelp globalHelp - CommandReadyToGo (_,(name:cmdArgs')) -> - case lookupCommand name of - [Command _ _ action] -> - case action ("--help":cmdArgs') of - CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> CommandHelp globalHelp - _ -> badCommand name - - where globalHelp = commandHelp globalCommand' - helpCommandUI = - (makeCommand "help" "Help about commands" Nothing () (const [])) { - commandUsage = \pname -> - "Usage: " ++ pname ++ " help [FLAGS]\n" - ++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n" - ++ "Flags for help:" - } - --- | Utility function, many commands do not accept additional flags. This --- action fails with a helpful error message if the user supplies any extra. --- -noExtraFlags :: [String] -> IO () -noExtraFlags [] = return () -noExtraFlags extraFlags = - die $ "Unrecognised flags: " ++ intercalate ", " extraFlags ---TODO: eliminate this function and turn it into a variant on commandAddAction --- instead like commandAddActionNoArgs that doesn't supply the [String] diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs deleted file mode 100644 --- a/Distribution/Simple/Compiler.hs +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Compiler --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Haskell implementations. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Compiler ( - -- * Haskell implementations - module Distribution.Compiler, - Compiler(..), - showCompilerId, compilerFlavor, compilerVersion, - - -- * Support for package databases - PackageDB(..), - - -- * Support for optimisation levels - OptimisationLevel(..), - flagToOptimisationLevel, - - -- * Support for language extensions - Flag, - extensionsToFlags, - unsupportedExtensions - ) where - -import Distribution.Compiler -import Distribution.Version (Version(..)) -import Distribution.Text (display) -import Language.Haskell.Extension (Extension(..)) - -import Data.List (nub) -import Data.Maybe (catMaybes, isNothing) - -data Compiler = Compiler { - compilerId :: CompilerId, - compilerExtensions :: [(Extension, String)] - } - deriving (Show, Read) - -showCompilerId :: Compiler -> String -showCompilerId = display . compilerId - -compilerFlavor :: Compiler -> CompilerFlavor -compilerFlavor = (\(CompilerId f _) -> f) . compilerId - -compilerVersion :: Compiler -> Version -compilerVersion = (\(CompilerId _ v) -> v) . compilerId - --- ------------------------------------------------------------ --- * Package databases --- ------------------------------------------------------------ - --- |Some compilers have a notion of a database of available packages. --- For some there is just one global db of packages, other compilers --- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isloated environments of --- packages, for example to build a collection of related packages --- without installing them globally. -data PackageDB = GlobalPackageDB - | UserPackageDB - | SpecificPackageDB FilePath - deriving (Eq, Show, Read) - --- ------------------------------------------------------------ --- * Optimisation levels --- ------------------------------------------------------------ - --- | Some compilers support optimising. Some have different levels. --- For compliers that do not the level is just capped to the level --- they do support. --- -data OptimisationLevel = NoOptimisation - | NormalOptimisation - | MaximumOptimisation - deriving (Eq, Show, Read, Enum, Bounded) - -flagToOptimisationLevel :: Maybe String -> OptimisationLevel -flagToOptimisationLevel Nothing = NormalOptimisation -flagToOptimisationLevel (Just s) = case reads s of - [(i, "")] - | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) - -> toEnum i - | otherwise -> error $ "Bad optimisation level: " ++ show i - ++ ". Valid values are 0..2" - _ -> error $ "Can't parse optimisation level " ++ s - --- ------------------------------------------------------------ --- * Extensions --- ------------------------------------------------------------ - --- |For the given compiler, return the extensions it does not support. -unsupportedExtensions :: Compiler -> [Extension] -> [Extension] -unsupportedExtensions comp exts = - [ ext | ext <- exts - , isNothing $ lookup ext (compilerExtensions comp) ] - -type Flag = String - --- |For the given compiler, return the flags for the supported extensions. -extensionsToFlags :: Compiler -> [Extension] -> [Flag] -extensionsToFlags comp exts = - nub $ filter (not . null) $ catMaybes - [ lookup ext (compilerExtensions comp) - | ext <- exts ] diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs deleted file mode 100644 --- a/Distribution/Simple/Configure.hs +++ /dev/null @@ -1,673 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Configure --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Perform the \"@.\/setup configure@\" action. --- Outputs the @dist\/setup-config@ file. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Configure (configure, - writePersistBuildConfig, - getPersistBuildConfig, - checkPersistBuildConfig, - maybeGetPersistBuildConfig, --- getConfiguredPkgDescr, - localBuildInfoFile, - getInstalledPackages, - configDependency, - configCompiler, configCompilerAux, - ccLdOptionsBuildInfo, - tryGetConfigStateFile, - ) - where - -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion - , showCompilerId, unsupportedExtensions, PackageDB(..) ) -import Distribution.Package - ( PackageIdentifier(PackageIdentifier), packageVersion, Package(..) - , Dependency(Dependency) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, emptyInstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(package,depends) ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.PackageDescription as PD - ( PackageDescription(..), GenericPackageDescription(..) - , Library(..), hasLibs, Executable(..), BuildInfo(..) - , HookedBuildInfo, updatePackageDescription, allBuildInfo - , FlagName(..) ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.PackageDescription.Check - ( PackageCheck(..) - , checkPackage, checkConfiguredPackage, checkPackageFiles ) -import Distribution.Simple.Program - ( Program(..), ProgramLocation(..), ConfiguredProgram(..) - , ProgramConfiguration, defaultProgramConfiguration - , configureAllKnownPrograms, knownPrograms - , userSpecifyArgs, userSpecifyPath - , lookupKnownProgram, requireProgram, pkgConfigProgram - , rawSystemProgramStdoutConf ) -import Distribution.Simple.Setup - ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), absoluteInstallDirs - , prefixRelativeInstallDirs ) -import Distribution.Simple.Utils - ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose - , intercalate, comparing, cabalVersion, cabalBootstrapping ) -import Distribution.Simple.Register - ( removeInstalledConfig ) -import Distribution.System - ( OS(..), buildOS, buildArch ) -import Distribution.Version - ( Version(..), VersionRange(..), orLaterVersion, withinRange ) -import Distribution.Verbosity - ( Verbosity, lessVerbose ) - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.JHC as JHC -import qualified Distribution.Simple.NHC as NHC -import qualified Distribution.Simple.Hugs as Hugs - -import Control.Monad - ( when, unless, foldM ) -import Control.Exception as Exception - ( catch ) -import Data.List - ( nub, partition, isPrefixOf, maximumBy ) -import Data.Maybe - ( fromMaybe, isNothing ) -import Data.Monoid - ( Monoid(..) ) -import System.Directory - ( doesFileExist, getModificationTime, createDirectoryIfMissing ) -import System.Exit - ( ExitCode(..), exitWith ) -import System.FilePath - ( (), isAbsolute ) -import qualified System.Info - ( compilerName, compilerVersion ) -import System.IO - ( hPutStrLn, stderr, hGetContents, openFile, hClose, IOMode(ReadMode) ) -import Distribution.Text - ( Text(disp), display, simpleParse ) -import Text.PrettyPrint.HughesPJ - ( comma, punctuate, render, nest, sep ) - -import Prelude hiding (catch) - -tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) -tryGetConfigStateFile filename = do - exists <- doesFileExist filename - if not exists - then return (Left missing) - else do - str <- readFileStrict filename - return $ case lines str of - [headder, rest] -> case checkHeader headder of - Just msg -> Left msg - Nothing -> case reads rest of - [(bi,_)] -> Right bi - _ -> Left cantParse - _ -> Left cantParse - where - readFileStrict name = do - h <- openFile name ReadMode - str <- hGetContents h >>= \str -> length str `seq` return str - hClose h - return str - checkHeader :: String -> Maybe String - checkHeader header = case parseHeader header of - Just (cabalId, compId) - | cabalId - == currentCabalId -> Nothing - | otherwise -> Just (badVersion cabalId compId) - Nothing -> Just cantParse - - missing = "Run the 'configure' command first." - cantParse = "Saved package config file seems to be corrupt. " - ++ "Try re-running the 'configure' command." - badVersion cabalId compId - = "You need to re-run the 'configure' command. " - ++ "The version of Cabal being used has changed (was " - ++ display cabalId ++ ", now " - ++ display currentCabalId ++ ")." - ++ badcompiler compId - badcompiler compId | compId == currentCompilerId = "" - | otherwise - = " Additionally the compiler is different (was " - ++ display compId ++ ", now " - ++ display currentCompilerId - ++ ") which is probably the cause of the problem." - --- internal function -tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo) -tryGetPersistBuildConfig distPref - = tryGetConfigStateFile (localBuildInfoFile distPref) - --- |Read the 'localBuildInfoFile'. Error if it doesn't exist. Also --- fail if the file containing LocalBuildInfo is older than the .cabal --- file, indicating that a re-configure is required. -getPersistBuildConfig :: FilePath -> IO LocalBuildInfo -getPersistBuildConfig distPref = do - lbi <- tryGetPersistBuildConfig distPref - either die return lbi - --- |Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig distPref = do - lbi <- tryGetPersistBuildConfig distPref - return $ either (const Nothing) Just lbi - --- |After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () -writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFile (localBuildInfoFile distPref) - (showHeader pkgid ++ '\n' : show lbi) - where - pkgid = packageId (localPkgDescr lbi) - -showHeader :: PackageIdentifier -> String -showHeader pkgid = - "Saved package config for " ++ display pkgid - ++ " written by " ++ display currentCabalId - ++ " using " ++ display currentCompilerId - where - -currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier "Cabal" currentVersion - where currentVersion | cabalBootstrapping = Version [0] [] - | otherwise = cabalVersion - -currentCompilerId :: PackageIdentifier -currentCompilerId = PackageIdentifier System.Info.compilerName - System.Info.compilerVersion - -parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) -parseHeader header = case words header of - ["Saved", "package", "config", "for", pkgid, - "written", "by", cabalid, "using", compilerid] - -> case (simpleParse pkgid :: Maybe PackageIdentifier, - simpleParse cabalid, - simpleParse compilerid) of - (Just _, - Just cabalid', - Just compilerid') -> Just (cabalid', compilerid') - _ -> Nothing - _ -> Nothing - --- |Check that localBuildInfoFile is up-to-date with respect to the --- .cabal file. -checkPersistBuildConfig :: FilePath -> FilePath -> IO () -checkPersistBuildConfig distPref pkg_descr_file = do - t0 <- getModificationTime pkg_descr_file - t1 <- getModificationTime $ localBuildInfoFile distPref - when (t0 > t1) $ - die (pkg_descr_file ++ " has been changed, please re-configure.") - --- |@dist\/setup-config@ -localBuildInfoFile :: FilePath -> FilePath -localBuildInfoFile distPref = distPref "setup-config" - --- ----------------------------------------------------------------------------- --- * Configuration --- ----------------------------------------------------------------------------- - --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: ( Either GenericPackageDescription PackageDescription - , HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0, pbi) cfg - = do let distPref = fromFlag (configDistPref cfg) - verbosity = fromFlag (configVerbosity cfg) - - setupMessage verbosity "Configuring" - (packageId (either packageDescription id pkg_descr0)) - - createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref - - let programsConfig = - flip (foldl userSpecifyArgs') (configProgramArgs cfg) - . flip (foldl userSpecifyPath') (configProgramPaths cfg) - $ configPrograms cfg - userSpecifyArgs' conf (prog, args) = userSpecifyArgs prog args conf - userSpecifyPath' conf (prog, path) = userSpecifyPath prog path conf - userInstall = fromFlag (configUserInstall cfg) - defaultPackageDB | userInstall = UserPackageDB - | otherwise = GlobalPackageDB - packageDb = fromFlagOrDefault defaultPackageDB - (configPackageDB cfg) - - -- detect compiler - (comp, programsConfig') <- configCompiler - (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) - programsConfig (lessVerbose verbosity) - let version = compilerVersion comp - flavor = compilerFlavor comp - - -- FIXME: currently only GHC has hc-pkg - maybePackageIndex <- getInstalledPackages (lessVerbose verbosity) comp - packageDb programsConfig' - - (pkg_descr0', flags) <- case pkg_descr0 of - Left ppd -> - case finalizePackageDescription - (configConfigurationsFlags cfg) - maybePackageIndex - Distribution.System.buildOS - Distribution.System.buildArch - (compilerId comp) - (configConstraints cfg) - ppd - of Right r -> return r - Left missing -> - die $ "At least the following dependencies are missing:\n" - ++ (render . nest 4 . sep . punctuate comma $ - map disp missing) - Right pd -> return (pd,[]) - - -- 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' - - when (not (null flags)) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ name ++ "=" ++ display value - | (FlagName name, value) <- flags ] - - checkPackageProblems verbosity - (either Just (\_->Nothing) pkg_descr0) --TODO: make the Either go away - (updatePackageDescription pbi pkg_descr) - - let packageIndex = fromMaybe bogusPackageIndex maybePackageIndex - -- FIXME: For Hugs, nhc98 and other compilers we do not know what - -- packages are already installed, so we just make some up, pretend - -- that they do exist and just hope for the best. We make them up - -- based on what other package the package we're currently building - -- happens to depend on. See 'inventBogusPackageId' below. - -- Let's hope they really are installed... :-) - bogusDependencies = map inventBogusPackageId (buildDepends pkg_descr) - bogusPackageIndex = PackageIndex.fromList - [ emptyInstalledPackageInfo { - InstalledPackageInfo.package = bogusPackageId - -- note that these bogus packages have no other dependencies - } - | bogusPackageId <- bogusDependencies ] - dep_pkgs <- case flavor of - GHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr) - JHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr) - _ -> return bogusDependencies - - packageDependsIndex <- - case PackageIndex.dependencyClosure packageIndex dep_pkgs of - Left packageDependsIndex -> return packageDependsIndex - Right broken -> - die $ "The following installed packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - ++ unlines [ "package " - ++ display (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map display deps) - | (pkg, deps) <- broken ] - - let pseudoTopPkg = emptyInstalledPackageInfo { - InstalledPackageInfo.package = packageId pkg_descr, - InstalledPackageInfo.depends = dep_pkgs - } - case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of - [] -> return () - inconsistencies -> - warn verbosity $ - "This package indirectly depends on multiple versions of the same " - ++ "package. This is highly likely to cause a compile failure.\n" - ++ unlines [ "package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (name, uses) <- inconsistencies - , (pkg, ver) <- uses ] - - removeInstalledConfig distPref - - -- installation directories - defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) - let installDirs = combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs cfg) - - -- check extensions - let extlist = nub $ concatMap extensions (allBuildInfo pkg_descr) - let exts = unsupportedExtensions comp extlist - unless (null exts) $ warn verbosity $ -- Just warn, FIXME: Should this be an error? - display flavor ++ " does not support the following extensions: " ++ - intercalate ", " (map display exts) - - let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) - programsConfig'' <- - configureAllKnownPrograms (lessVerbose verbosity) programsConfig' - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr', programsConfig''') <- configurePkgconfigPackages verbosity - pkg_descr programsConfig'' - - split_objs <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case flavor of - GHC | version >= Version [6,5] [] -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False - - let lbi = LocalBuildInfo{ - installDirTemplates = installDirs, - compiler = comp, - buildDir = distPref "build", - scratchDir = fromFlagOrDefault - (distPref "scratch") - (configScratchDir cfg), - packageDeps = dep_pkgs, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programsConfig''', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withProfLib = fromFlag $ configProfLib cfg, - withSharedLib = fromFlag $ configSharedLib cfg, - withProfExe = fromFlag $ configProfExe cfg, - withOptimization = fromFlag $ configOptimization cfg, - withGHCiLib = fromFlag $ configGHCiLib cfg, - splitObjs = split_objs, - stripExes = fromFlag $ configStripExes cfg, - withPackageDB = packageDb, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg - } - - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs pkg_descr lbi - - unless (isAbsolute (prefix dirs)) $ die $ - "expected an absolute directory name for --prefix: " ++ prefix dirs - - info verbosity $ "Using " ++ display currentCabalId - ++ " compiled by " ++ display currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where relNote = case buildOS of - Windows | not (hasLibs pkg_descr) - && isNothing isPrefixRelative - -> " (fixed location)" - _ -> "" - - dirinfo "Binaries" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - - sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programsConfig''' ] - - return lbi - - where - addExtraIncludeLibDirs pkg_descr = - let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg - , PD.includeDirs = configExtraIncludeDirs cfg} - modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi } - modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi} - in pkg_descr{ library = modifyLib `fmap` library pkg_descr - , executables = modifyExecutable `map` executables pkg_descr} --- ----------------------------------------------------------------------------- --- Configuring package dependencies - --- |Converts build dependencies to a versioned dependency. only sets --- version information for exact versioned dependencies. -inventBogusPackageId :: Dependency -> PackageIdentifier - --- if they specify the exact version, use that: -inventBogusPackageId (Dependency s (ThisVersion v)) = PackageIdentifier s v - --- otherwise, just set it to empty -inventBogusPackageId (Dependency s _) = PackageIdentifier s (Version [] []) - -reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing - = info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) - = info verbosity $ "Using " ++ programName prog ++ version ++ location - where location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ display v - -hackageUrl :: String -hackageUrl = "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/" - --- | Test for a package dependency and record the version we have installed. -configDependency :: Verbosity -> PackageIndex InstalledPackageInfo -> Dependency -> IO PackageIdentifier -configDependency verbosity index dep@(Dependency pkgname vrange) = - case PackageIndex.lookupDependency index dep of - [] -> die $ "cannot satisfy dependency " - ++ pkgname ++ display vrange ++ "\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ pkgname ++ "?" - pkgs -> do let pkgid = maximumBy (comparing packageVersion) (map packageId pkgs) - info verbosity $ "Dependency " ++ pkgname - ++ display vrange - ++ ": using " ++ display pkgid - return pkgid - -getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration - -> IO (Maybe (PackageIndex InstalledPackageInfo)) -getInstalledPackages verbosity comp packageDb progconf = do - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDb progconf - JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDb progconf - _ -> return Nothing - --- ----------------------------------------------------------------------------- --- Configuring program dependencies - -configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration -configureRequiredPrograms verbosity deps conf = - foldM (configureRequiredProgram verbosity) conf deps - -configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration -configureRequiredProgram verbosity conf (Dependency progName verRange) = - case lookupKnownProgram progName conf of - Nothing -> die ("Unknown build tool " ++ show progName) - Just prog -> snd `fmap` requireProgram verbosity prog verRange conf - --- ----------------------------------------------------------------------------- --- Configuring pkg-config package dependencies - -configurePkgconfigPackages :: Verbosity -> PackageDescription - -> ProgramConfiguration - -> IO (PackageDescription, ProgramConfiguration) -configurePkgconfigPackages verbosity pkg_descr conf - | null allpkgs = return (pkg_descr, conf) - | otherwise = do - (_, conf') <- requireProgram (lessVerbose verbosity) pkgConfigProgram - (orLaterVersion $ Version [0,9,0] []) conf - mapM_ requirePkg allpkgs - lib' <- updateLibrary (library pkg_descr) - exes' <- mapM updateExecutable (executables pkg_descr) - let pkg_descr' = pkg_descr { library = lib', executables = exes' } - return (pkg_descr', conf') - - where - allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) - pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) - pkgConfigProgram conf - - requirePkg (Dependency pkg range) = do - version <- pkgconfig ["--modversion", pkg] - `Exception.catch` \_ -> die notFound - case simpleParse version of - Nothing -> die "parsing output of pkg-config --modversion failed" - Just v | not (withinRange v range) -> die (badVersion v) - | otherwise -> info verbosity (depSatisfied v) - where - notFound = "The pkg-config package " ++ pkg ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ display v - depSatisfied v = "Dependency " ++ pkg ++ display range - ++ ": using version " ++ display v - - versionRequirement - | range == AnyVersion = "" - | otherwise = " version " ++ display range - - updateLibrary Nothing = return Nothing - updateLibrary (Just lib) = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib)) - return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi } - - updateExecutable exe = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe)) - return exe { buildInfo = buildInfo exe `mappend` bi } - - pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo - pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ pkg | Dependency pkg _ <- pkgdeps ] - ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) - --- | Makes a 'BuildInfo' from C compiler and linker flags. --- --- This can be used with the output from configuration programs like pkg-config --- and similar package-specific programs like mysql-config, freealut-config etc. --- For example: --- --- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] --- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) --- -ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags = - let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags - (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags - (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - in mempty { - PD.includeDirs = map (drop 2) includeDirs', - PD.extraLibs = map (drop 2) extraLibs', - PD.extraLibDirs = map (drop 2) extraLibDirs', - PD.ccOptions = cflags', - PD.ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) -configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - defaultProgramConfiguration - (fromFlag (configVerbosity cfg)) - -configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> Verbosity - -> IO (Compiler, ProgramConfiguration) -configCompiler Nothing _ _ _ _ = die "Unknown compiler" -configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do - case hcFlavor of - GHC -> GHC.configure verbosity hcPath hcPkg conf - JHC -> JHC.configure verbosity hcPath hcPkg conf - Hugs -> Hugs.configure verbosity hcPath hcPkg conf - NHC -> NHC.configure verbosity hcPath hcPkg conf - _ -> die "Unknown compiler" - - --- | Output package check warnings and errors. Exit if any errors. -checkPackageProblems :: Verbosity - -> Maybe GenericPackageDescription - -> PackageDescription - -> IO () -checkPackageProblems verbosity mgpkg pkg = do - ioChecks <- checkPackageFiles pkg "." - let pureChecks = case mgpkg of - Just gpkg -> checkPackage gpkg (Just pkg) - Nothing -> checkConfiguredPackage pkg - errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] - warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] - if null errors - then mapM_ (warn verbosity) warnings - else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors - exitWith (ExitFailure 1) - --- ----------------------------------------------------------------------------- --- Tests - -{- Too specific: -hunitTests :: [Test] -hunitTests = [] -packageID = PackageIdentifier "Foo" (Version [1] []) - = [TestCase $ - do let simonMarGHCLoc = "/usr/bin/ghc" - simonMarGHC <- configure emptyPackageDescription {package=packageID} - (Just GHC, - Just simonMarGHCLoc, - Nothing, Nothing) - assertEqual "finding ghc, etc on simonMar's machine failed" - (LocalBuildInfo "/usr" (Compiler GHC - (Version [6,2,2] []) simonMarGHCLoc - (simonMarGHCLoc ++ "-pkg")) [] []) - simonMarGHC - ] --} diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs deleted file mode 100644 --- a/Distribution/Simple/GHC.hs +++ /dev/null @@ -1,800 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC --- Copyright : Isaac Jones 2003-2007 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Build and Install implementations for GHC. See --- 'Distribution.Simple.GHC.PackageConfig.GHCPackageConfig' for --- registration-related stuff. - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modiication, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.GHC ( - configure, getInstalledPackages, build, makefile, installLib, installExe, - ghcOptions, - ghcVerbosityOptions - ) where - -import Distribution.Simple.GHC.Makefile -import Distribution.Simple.Setup ( MakefileFlags(..), - fromFlag, fromFlagOrDefault) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), - withLib, - Executable(..), withExe, Library(..), - libModules, hcOptions ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo - , parseInstalledPackageInfo ) -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.ParseUtils ( ParseResult(..) ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package - ( PackageIdentifier, Package(..) ) -import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration - , rawSystemProgram, rawSystemProgramConf - , rawSystemProgramStdout, rawSystemProgramStdoutConf, requireProgram - , userMaybeSpecifyPath, programPath, lookupProgram, updateProgram - , ghcProgram, ghcPkgProgram, arProgram, ranlibProgram, ldProgram - , stripProgram ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion - , OptimisationLevel(..), PackageDB(..), Flag, extensionsToFlags ) -import Distribution.Version - ( Version(..), VersionRange(..), orLaterVersion ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity -import Distribution.Text - ( display, simpleParse ) -import Language.Haskell.Extension (Extension(..)) - -import Control.Monad ( unless, when ) -import Data.Char -import Data.List ( nub ) -import Data.Maybe ( catMaybes ) -import Data.Monoid ( Monoid(mconcat) ) -import System.Directory ( removeFile, renameFile, - getDirectoryContents, doesFileExist, - getTemporaryDirectory ) -import System.FilePath ( (), (<.>), takeExtension, - takeDirectory, replaceExtension, splitExtension ) -import System.IO (openFile, IOMode(WriteMode), hClose, hPutStrLn) -import Control.Exception as Exception - ( catch, handle, try ) - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath hcPkgPath conf = do - - (ghcProg, conf') <- requireProgram verbosity ghcProgram - (orLaterVersion (Version [6,4] [])) - (userMaybeSpecifyPath "ghc" hcPath conf) - let Just ghcVersion = programVersion ghcProg - - -- 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, conf'') <- requireProgram verbosity ghcPkgProgram { - programFindLocation = guessGhcPkgFromGhcPath ghcProg - } - (orLaterVersion (Version [0] [])) - (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf') - let Just ghcPkgVersion = programVersion ghcPkgProg - - when (ghcVersion /= ghcPkgVersion) $ die $ - "Version mismatch between ghc and ghc-pkg: " - ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " - ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion - - -- finding ghc's local ld is a bit tricky as it's not on the path: - let ldProgram' = case buildOS of - Windows -> - let compilerDir = takeDirectory (programPath ghcProg) - baseDir = takeDirectory compilerDir - binInstallLd = baseDir "gcc-lib" "ld.exe" - in ldProgram { - programFindLocation = \_ -> return (Just binInstallLd) - } - _ -> ldProgram - - -- we need to find out if ld supports the -x flag - (ldProg, conf''') <- requireProgram verbosity ldProgram' AnyVersion conf'' - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() {}" - hClose testchnd; hClose testohnd - rawSystemProgram verbosity ghcProg ["-c", testcfile, - "-o", testofile] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - handle (\_ -> return False) $ do - hClose testohnd' - rawSystemProgramStdout verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - let conf'''' = updateProgram ldProg { - programArgs = if ldx then ["-x"] else [] - } conf''' - -- Yeah yeah, so obviously conf''''' is totally rediculious and the program - -- configuration needs to be in a state monad. That is exactly the plan - -- (along with some other stuff to give Cabal a better DSL). - - languageExtensions <- - if ghcVersion >= Version [6,7] [] - then do exts <- rawSystemStdout verbosity (programPath ghcProg) - ["--supported-languages"] - -- GHC has the annoying habit of inverting some of the extensions - -- so we have to try parsing ("No" ++ ghcExtensionName) first - let readExtension str = do - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext - return [ (ext, "-X" ++ display ext) - | Just ext <- map readExtension (lines exts) ] - else return oldLanguageExtensions - - let comp = Compiler { - compilerId = CompilerId GHC ghcVersion, - compilerExtensions = languageExtensions - } - return (comp, conf'''') - --- | 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-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath) -guessGhcPkgFromGhcPath ghcProg verbosity - = do let path = programPath ghcProg - dir = takeDirectory path - versionSuffix = takeVersionSuffix (dropExeExtension path) - guessNormal = dir "ghc-pkg" <.> exeExtension - guessVersioned = dir ("ghc-pkg" ++ versionSuffix) <.> exeExtension - guesses | null versionSuffix = [guessNormal] - | otherwise = [guessVersioned, guessNormal] - info verbosity $ "looking for package tool: ghc-pkg near compiler in " ++ dir - exists <- mapM doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - [] -> return Nothing - (pkgtool:_) -> do info verbosity $ "found package tool in " ++ pkgtool - return (Just pkgtool) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse - - dropExeExtension :: FilePath -> FilePath - dropExeExtension filepath = - case splitExtension filepath of - (filepath', extension) | extension == exeExtension -> filepath' - | otherwise -> filepath - --- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags -oldLanguageExtensions :: [(Extension, Flag)] -oldLanguageExtensions = - [(OverlappingInstances , "-fallow-overlapping-instances") - ,(TypeSynonymInstances , "-fglasgow-exts") - ,(TemplateHaskell , "-fth") - ,(ForeignFunctionInterface , "-fffi") - ,(NoMonomorphismRestriction , "-fno-monomorphism-restriction") - ,(NoMonoPatBinds , "-fno-mono-pat-binds") - ,(UndecidableInstances , "-fallow-undecidable-instances") - ,(IncoherentInstances , "-fallow-incoherent-instances") - ,(Arrows , "-farrows") - ,(Generics , "-fgenerics") - ,(NoImplicitPrelude , "-fno-implicit-prelude") - ,(ImplicitParams , "-fimplicit-params") - ,(CPP , "-cpp") - ,(BangPatterns , "-fbang-patterns") - ,(KindSignatures , fglasgowExts) - ,(RecursiveDo , fglasgowExts) - ,(ParallelListComp , fglasgowExts) - ,(MultiParamTypeClasses , fglasgowExts) - ,(FunctionalDependencies , fglasgowExts) - ,(Rank2Types , fglasgowExts) - ,(RankNTypes , fglasgowExts) - ,(PolymorphicComponents , fglasgowExts) - ,(ExistentialQuantification , fglasgowExts) - ,(ScopedTypeVariables , "-fscoped-type-variables") - ,(FlexibleContexts , fglasgowExts) - ,(FlexibleInstances , fglasgowExts) - ,(EmptyDataDecls , fglasgowExts) - ,(PatternGuards , fglasgowExts) - ,(GeneralizedNewtypeDeriving , fglasgowExts) - ,(MagicHash , fglasgowExts) - ,(UnicodeSyntax , fglasgowExts) - ,(PatternSignatures , fglasgowExts) - ,(UnliftedFFITypes , fglasgowExts) - ,(LiberalTypeSynonyms , fglasgowExts) - ,(TypeOperators , fglasgowExts) - ,(GADTs , fglasgowExts) - ,(RelaxedPolyRec , fglasgowExts) - ,(ExtendedDefaultRules , "-fextended-default-rules") - ,(UnboxedTuples , fglasgowExts) - ,(DeriveDataTypeable , fglasgowExts) - ,(ConstrainedClassMethods , fglasgowExts) - ] - where - fglasgowExts = "-fglasgow-exts" - -getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration - -> IO (PackageIndex InstalledPackageInfo) -getInstalledPackages verbosity packagedb conf = do - let packagedbs = case packagedb of - GlobalPackageDB -> [GlobalPackageDB] - _ -> [GlobalPackageDB, packagedb] - pkgss <- getInstalledPackages' verbosity packagedbs conf - return $ mconcat [ PackageIndex.fromList pkgs - | (_, pkgs) <- pkgss ] - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs conf - | ghcVersion >= Version [6,9] [] = - sequence - [ do str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf - ["describe", "*", packageDbGhcPkgFlag packagedb] - `Exception.catch` \_ -> die $ - "ghc-pkg describe * failed. If you are using ghc-6.9 " - ++ "and have an empty user package database then this " - ++ "is probably due to ghc bug #2201. The workaround is to " - ++ "register at least one package in the user package db." - case parsePackages str of - Left ok -> return (packagedb, ok) - _ -> die "failed to parse output of 'ghc-pkg describe *'" - | packagedb <- packagedbs ] - - where - parsePackages str = - let parsed = map parseInstalledPackageInfo (splitPkgs str) - in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ pkg | ParseOk _ pkg <- parsed ] - msgs -> Right msgs - - Just ghcProg = lookupProgram ghcProgram conf - Just ghcVersion = programVersion ghcProg - - splitPkgs :: String -> [String] - splitPkgs = map unlines . split [] . lines - where split [] [] = [] - split acc [] = [reverse acc] - split acc (l@('n':'a':'m':'e':':':_):ls) - | null acc = split (l:[]) ls - | otherwise = reverse acc : split (l:[]) ls - split acc (l:ls) = split (l:acc) ls - - packageDbGhcPkgFlag GlobalPackageDB = "--global" - packageDbGhcPkgFlag UserPackageDB = "--user" - packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path - -getInstalledPackages' verbosity packagedbs conf = do - str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"] - let pkgFiles = [ init line | line <- lines str, last line == ':' ] - dbFile packagedb = case (packagedb, pkgFiles) of - (GlobalPackageDB, global:_) -> return $ Just global - (UserPackageDB, _global:user:_) -> return $ Just user - (UserPackageDB, _global:_) -> return $ Nothing - (SpecificPackageDB specific, _) -> return $ Just specific - _ -> die "cannot read ghc-pkg package listing" - pkgFiles' <- mapM dbFile packagedbs - sequence [ withFileContents file $ \content -> - case reads content of - [(pkgs, _)] -> return (db, pkgs) - _ -> die $ "cannot read ghc package database " ++ file - | (db , Just file) <- zip packagedbs pkgFiles' ] - --- ----------------------------------------------------------------------------- --- Building - --- |Building for GHC. If .ghc-packages exists and is readable, add --- it to the command-line. -build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -build pkg_descr lbi verbosity = do - let pref = buildDir lbi - pkgid = packageId pkg_descr - runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) - ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) - ifProfLib = when (withProfLib lbi) - ifSharedLib = when (withSharedLib lbi) - ifGHCiLib = when (withGHCiLib lbi) - - -- Build lib - withLib pkg_descr () $ \lib -> do - info verbosity "Building library..." - let libBi = libBuildInfo lib - libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` extensions libBi - -- TH always needs vanilla libs, even when building for profiling - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recurive modules? - let ghcArgs = - ["-package-name", display pkgid ] - ++ constructGHCCmdLine lbi libBi libTargetDir verbosity - ++ (libModules pkg_descr) - ghcArgsProf = ghcArgs - ++ ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] - ++ ghcProfOptions libBi - ghcArgsShared = ghcArgs - ++ ["-dynamic", - "-hisuf", "dyn_hi", - "-osuf", "dyn_o", "-fPIC" - ] - ++ ghcSharedOptions libBi - unless (null (libModules pkg_descr)) $ - do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs) - ifProfLib (runGhcProg ghcArgsProf) - ifSharedLib (runGhcProg ghcArgsShared) - - -- build any C sources - unless (null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi pref - filename verbosity - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) - | filename <- cSources libBi] - - -- link: - info verbosity "Linking..." - let cObjs = map (`replaceExtension` objExtension) (cSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) - vanillaLibFilePath = libTargetDir mkLibName pkgid - profileLibFilePath = libTargetDir mkProfLibName pkgid - sharedLibFilePath = libTargetDir mkSharedLibName pkgid - (compilerId (compiler lbi)) - ghciLibFilePath = libTargetDir mkGHCiLibName pkgid - - stubObjs <- fmap catMaybes $ sequence - [ findFileWithExtension [objExtension] [libTargetDir] - (dotToSep x ++"_stub") - | x <- libModules pkg_descr ] - stubProfObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (dotToSep x ++"_stub") - | x <- libModules pkg_descr ] - stubSharedObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (dotToSep x ++"_stub") - | x <- libModules pkg_descr ] - - hObjs <- getHaskellObjects pkg_descr libBi lbi - pref objExtension True - hProfObjs <- - if (withProfLib lbi) - then getHaskellObjects pkg_descr libBi lbi - pref ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if (withSharedLib lbi) - then getHaskellObjects pkg_descr libBi lbi - pref ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - -- first remove library files if they exists - sequence_ - [ try (removeFile libFilePath) - | libFilePath <- [vanillaLibFilePath, profileLibFilePath - ,sharedLibFilePath, ghciLibFilePath] ] - - let arVerbosity | verbosity >= deafening = "v" - | verbosity >= normal = "" - | otherwise = "c" - arArgs = ["q"++ arVerbosity] - ++ [vanillaLibFilePath] - arObjArgs = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - arProfArgs = ["q"++ arVerbosity] - ++ [profileLibFilePath] - arProfObjArgs = - hProfObjs - ++ map (pref ) cObjs - ++ stubProfObjs - ldArgs = ["-r"] - ++ ["-o", ghciLibFilePath <.> "tmp"] - ldObjArgs = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - ghcSharedObjArgs = - hSharedObjs - ++ map (pref ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - [ "-shared", - "-dynamic", - "-o", sharedLibFilePath ] - ++ ghcSharedObjArgs - ++ ["-package-name", display pkgid ] - ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) - ++ ["-l"++extraLib | extraLib <- extraLibs libBi] - ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] - - runLd ldLibName args = do - exists <- doesFileExist ldLibName - -- This method is called iteratively by xargs. The - -- output goes to .tmp, and any existing file - -- named is included when linking. The - -- output is renamed to . - rawSystemProgramConf verbosity ldProgram (withPrograms lbi) - (args ++ if exists then [ldLibName] else []) - renameFile (ldLibName <.> "tmp") ldLibName - - runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) - - --TODO: discover this at configure time or runtime on unix - -- The value is 32k on Windows and posix specifies a minimum of 4k - -- but all sensible unixes use more than 4k. - -- we could use getSysVar ArgumentLimit but that's in the unix lib - maxCommandLineSize = 30 * 1024 - - ifVanillaLib False $ xargs maxCommandLineSize - runAr arArgs arObjArgs - - ifProfLib $ xargs maxCommandLineSize - runAr arProfArgs arProfObjArgs - - ifGHCiLib $ xargs maxCommandLineSize - (runLd ghciLibFilePath) ldArgs ldObjArgs - - ifSharedLib $ runGhcProg ghcSharedLinkArgs - - -- build any executables - withExe pkg_descr $ \Executable { exeName = exeName', modulePath = modPath, - buildInfo = exeBi } -> do - info verbosity $ "Building executable: " ++ exeName' ++ "..." - - -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' <.> - (if null $ takeExtension exeName' then exeExtension else "") - - let targetDir = pref exeName' - let exeDir = targetDir (exeName' ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True exeDir - -- TODO: do we need to put hs-boot files into place for mutually recursive modules? - -- FIX: what about exeName.hi-boot? - - -- build executables - unless (null (cSources exeBi)) $ do - info verbosity "Building C Sources." - sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi - exeDir filename verbosity - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - | filename <- cSources exeBi] - - srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath - - let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) - let binArgs linkExe profExe = - (if linkExe - then ["-o", targetDir exeNameReal] - else ["-c"]) - ++ constructGHCCmdLine lbi exeBi exeDir verbosity - ++ [exeDir x | x <- cObjs] - ++ [srcMainFile] - ++ ldOptions exeBi - ++ ["-l"++lib | lib <- extraLibs exeBi] - ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] - ++ concat [["-framework", f] | f <- frameworks exeBi] - ++ if profExe - then ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] ++ ghcProfOptions exeBi - else [] - - -- For building exe's for profiling that use TH we actually - -- have to build twice, once without profiling and the again - -- with profiling. This is because the code that TH needs to - -- run at compile time needs to be the vanilla ABI so it can - -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi) - (runGhcProg (binArgs False False)) - - runGhcProg (binArgs True (withProfExe lbi)) - - --- when using -split-objs, we need to search for object files in the --- Module_split directory for each module. -getHaskellObjects :: PackageDescription -> BuildInfo -> LocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects pkg_descr _ lbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let dirs = [ pref (dotToSep x ++ "_split") - | x <- libModules pkg_descr ] - objss <- mapM getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref dotToSep x <.> wanted_obj_ext - | x <- libModules pkg_descr ] - - -constructGHCCmdLine - :: LocalBuildInfo - -> BuildInfo - -> FilePath - -> Verbosity - -> [String] -constructGHCCmdLine lbi bi odir verbosity = - ["--make"] - ++ ghcVerbosityOptions verbosity - -- Unsupported extensions have already been checked by configure - ++ ghcOptions lbi bi odir - -ghcVerbosityOptions :: Verbosity -> [String] -ghcVerbosityOptions verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - -ghcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] -ghcOptions lbi bi odir - = ["-hide-all-packages"] - ++ (case withPackageDB lbi of - GlobalPackageDB -> ["-no-user-package-conf"] - UserPackageDB -> [] - SpecificPackageDB db -> ["-no-user-package-conf" - ,"-package-conf", db]) - ++ (if splitObjs lbi then ["-split-objs"] else []) - ++ ["-i"] - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - ++ ["-I" ++ odir] - ++ ["-I" ++ dir | dir <- includeDirs bi] - ++ ["-optP" ++ opt | opt <- cppOptions bi] - ++ ["-optc" ++ opt | opt <- ccOptions bi] - ++ [ "-#include \"" ++ inc ++ "\"" | inc <- includes bi ] - ++ [ "-odir", odir, "-hidir", odir ] - ++ (if compilerVersion c >= Version [6,8] [] - then ["-stubdir", odir] else []) - ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) - ++ (case withOptimization lbi of - NoOptimisation -> [] - NormalOptimisation -> ["-O"] - MaximumOptimisation -> ["-O2"]) - ++ hcOptions GHC bi - ++ extensionsToFlags c (extensions bi) - where c = compiler lbi - -constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath - -> FilePath -> Verbosity -> (FilePath,[String]) -constructCcCmdLine lbi bi pref filename verbosity - = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref - | otherwise = pref takeDirectory filename - -- ghc 6.4.1 fixed a bug in -odir handling - -- for C compilations. - in - (odir, - ghcCcOptions lbi bi odir - ++ (if verbosity >= deafening then ["-v"] else []) - ++ ["-c",filename]) - - -ghcCcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] -ghcCcOptions lbi bi odir - = ["-I" ++ dir | dir <- includeDirs bi] - ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] - ++ ["-optc" ++ opt | opt <- ccOptions bi] - ++ (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-optc-O2"]) - ++ ["-odir", odir] - -mkGHCiLibName :: PackageIdentifier -> String -mkGHCiLibName lib = "HS" ++ display lib <.> "o" - --- ----------------------------------------------------------------------------- --- Building a Makefile - -makefile :: PackageDescription -> LocalBuildInfo -> MakefileFlags -> IO () -makefile pkg_descr lbi flags = do - let file = fromFlagOrDefault "Makefile"(makefileFile flags) - verbosity = fromFlag (makefileVerbosity flags) - targetExists <- doesFileExist file - when targetExists $ - die ("Not overwriting existing copy of " ++ file) - h <- openFile file WriteMode - - let Just lib = library pkg_descr - bi = libBuildInfo lib - - packageIdStr = display (packageId pkg_descr) - (arProg, _) <- requireProgram verbosity arProgram AnyVersion - (withPrograms lbi) - (ldProg, _) <- requireProgram verbosity ldProgram AnyVersion - (withPrograms lbi) - let builddir = buildDir lbi - Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) - let decls = [ - ("modules", unwords (exposedModules lib ++ otherModules bi)), - ("GHC", programPath ghcProg), - ("GHC_VERSION", (display (compilerVersion (compiler lbi)))), - ("WAYS", (if withProfLib lbi then "p " else "") ++ (if withSharedLib lbi then "dyn" else "")), - ("odir", builddir), - ("srcdir", case hsSourceDirs bi of - [one] -> one - _ -> error "makefile: can't cope with multiple hs-source-dirs yet, sorry"), - ("package", packageIdStr), - ("GHC_OPTS", unwords ( - ["-package-name", packageIdStr ] - ++ ghcOptions lbi bi (buildDir lbi))), - ("MAKEFILE", file), - ("C_SRCS", unwords (cSources bi)), - ("GHC_CC_OPTS", unwords (ghcCcOptions lbi bi (buildDir lbi))), - ("GHCI_LIB", builddir mkGHCiLibName (packageId pkg_descr)), - ("soext", dllExtension), - ("LIB_LD_OPTS", unwords (["-package-name", packageIdStr] - ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] - ++ ["-l"++libName | libName <- extraLibs bi] - ++ ["-L"++libDir | libDir <- extraLibDirs bi])), - ("AR", programPath arProg), - ("LD", programPath ldProg ++ concat [" " ++ arg | arg <- programArgs ldProg ]) - ] - hPutStrLn h "# DO NOT EDIT! Automatically generated by Cabal\n" - hPutStrLn h (unlines (map (\(a,b)-> a ++ " = " ++ munge b) decls)) - hPutStrLn h makefileTemplate - hClose h - where - munge "" = "" - munge ('#':s) = '\\':'#':munge s - munge ('\\':s) = '/':munge s - -- for Windows, we want to use forward slashes in our pathnames in the Makefile - munge (c:s) = c : munge s - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHC. -installExe :: Verbosity -- ^verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> IO () -installExe verbosity lbi pref buildPref (progprefix, progsuffix) pkg_descr - = do createDirectoryIfMissingVerbose verbosity True pref - withExe pkg_descr $ \Executable { exeName = e } -> do - let exeFileName = e <.> exeExtension - fixedExeFileName = (progprefix ++ e ++ progsuffix) <.> exeExtension - copyFileVerbose verbosity (buildPref e exeFileName) (pref fixedExeFileName) - stripExe verbosity lbi exeFileName (pref fixedExeFileName) - -stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () -stripExe verbosity lbi name path = when (stripExes lbi) $ - case lookupProgram stripProgram (withPrograms lbi) of - Just strip -> rawSystemProgram verbosity strip args - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable '" ++ name - ++ "' (missing the 'strip' program)" - where - args = path : case buildOS of - OSX -> ["-x"] -- By default, stripping the ghc binary on at least - -- some OS X installations causes: - -- HSbase-3.0.o: unknown symbol `_environ'" - -- The -x flag fixes that. - _ -> [] - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity -- ^verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic librarys - -> FilePath -- ^Build location - -> PackageDescription -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir - pkg@PackageDescription{library=Just lib} = do - -- copy .hi files over: - let copyModuleFiles ext = - smartCopySources verbosity [builtDir] targetDir (libModules pkg) [ext] - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" - - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copy builtDir dynlibTargetDir sharedLibName - - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi (targetDir profileLibName) - - where - vanillaLibName = mkLibName pkgid - profileLibName = mkProfLibName pkgid - ghciLibName = mkGHCiLibName pkgid - sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) - - pkgid = packageId pkg - copy src dst n = copyFileVerbose verbosity (src n) (dst n) - - hasLib = not $ null (libModules pkg) - && null (cSources (libBuildInfo lib)) - ifVanilla = when (hasLib && withVanillaLib lbi) - ifProf = when (hasLib && withProfLib lbi) - ifGHCi = when (hasLib && withGHCiLib lbi) - ifShared = when (hasLib && withSharedLib lbi) - -installLib _ _ _ _ _ PackageDescription{library=Nothing} - = die $ "Internal Error. installLibGHC called with no library." - --- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems --- like MacOS X. If we can't find those, don't worry too much about it. --- -updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () -updateLibArchive verbosity lbi path = - case lookupProgram ranlibProgram (withPrograms lbi) of - Just ranlib -> rawSystemProgram verbosity ranlib [path] - Nothing -> case lookupProgram arProgram (withPrograms lbi) of - Just ar -> rawSystemProgram verbosity ar ["-s", path] - Nothing -> warn verbosity $ - "Unable to generate a symbol index for the static " - ++ "library '" ++ path - ++ "' (missing the 'ranlib' and 'ar' programs)" diff --git a/Distribution/Simple/GHC/Makefile.hs b/Distribution/Simple/GHC/Makefile.hs deleted file mode 100644 --- a/Distribution/Simple/GHC/Makefile.hs +++ /dev/null @@ -1,5 +0,0 @@ --- DO NOT EDIT: change Makefile.in, and run ../../../mkGHCMakefile.sh -module Distribution.Simple.GHC.Makefile where { -makefileTemplate :: String; makefileTemplate=unlines -["# -----------------------------------------------------------------------------","# Makefile template starts here.","","GHC_OPTS += -i$(odir)","","# For adding options on the command-line","GHC_OPTS += $(EXTRA_HC_OPTS)","","WAY_p_OPTS = -prof","WAY_dyn_OPTS = -fPIC -dynamic","WAY_dyn_CC_OPTS = -fPIC","","ifneq \"$(way)\" \"\"","way_ := $(way)_","_way := _$(way)","GHC_OPTS += $(WAY_$(way)_OPTS)","GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf)","GHC_CC_OPTS += $(WAY_$(way)_CC_OPTS)","endif","osuf = $(way_)o","hisuf = $(way_)hi","","HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules)))","HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules)))","C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS))","","ifeq \"$(way:%dyn=YES)\" \"YES\"","LIB = $(odir)/libHS$(package)$(_way:%_dyn=%)-ghc$(GHC_VERSION)$(soext)","else","LIB = $(odir)/libHS$(package)$(_way).a","endif","","RM = rm -f","","# Optionally include local customizations:","-include Makefile.local","","# Rules follow:","","MKSTUBOBJS = find $(odir) -name \"*_stub.$(osuf)\" -print","# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to ","# make using cached directory contents, or something.","","all :: $(odir)/.depend $(LIB)","","$(odir)/.depend : $(MAKEFILE)","\t$(GHC) -M -optdep-f -optdep$(odir)/.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules)","\tfor dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \\","\t\tif test ! -d $$dir; then mkdir -p $$dir; fi \\","\tdone","","include $(odir)/.depend","","ifeq \"$(way:%dyn=YES)\" \"YES\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(GHC) -shared -dynamic -o $@ $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` $(LIB_LD_OPTS)","else","ifneq \"$(filter -split-objs, $(GHC_OPTS))\" \"\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t(echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs $(AR) q $(EXTRA_AR_ARGS) $@ ","else","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\techo $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` | xargs $(AR) q $(EXTRA_AR_ARGS) $@","endif","endif","","ifneq \"$(GHCI_LIB)\" \"\"","ifeq \"$(way)\" \"\"","all :: $(GHCI_LIB)","","$(GHCI_LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(LD) -r -o $@ $(EXTRA_LD_OPTS) $(HS_OBJS) `$(MKSTUBOBJS)` $(C_OBJS)","endif","endif","","# suffix rules","","ifneq \"$(odir)\" \"\"","odir_ = $(odir)/","else","odir_ =","endif","","$(odir_)%.$(osuf) : $(srcdir)/%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(srcdir)/%.lhs\t ","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","# The .hs files might be in $(odir) if they were preprocessed","$(odir_)%.$(osuf) : $(odir_)%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(odir_)%.lhs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(srcdir)/%.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(osuf) : $(srcdir)/%.$(way_)s","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(osuf) : $(srcdir)/%.S","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(way_)s : $(srcdir)/%.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -S $< -o $@","","$(odir_)%.$(osuf)-boot : $(srcdir)/%.hs-boot","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot","","$(odir_)%.$(osuf)-boot : $(srcdir)/%.lhs-boot","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot","","%.$(hisuf) : %.$(osuf)","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","%.$(way_)hi-boot : %.$(osuf)-boot","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","$(odir_)%.$(hisuf) : %.$(way_)hc","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","show:","\t@echo '$(VALUE)=\"$($(VALUE))\"'","","clean ::","\t$(RM) $(HS_OBJS) $(C_OBJS) $(LIB) $(GHCI_LIB) $(HS_IFS) .depend","\t$(RM) -rf $(wildcard $(patsubst %.$(osuf), %_split, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.o-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.hi-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %_stub.o, $(HS_OBJS)))","","ifneq \"$(strip $(WAYS))\" \"\"","ifeq \"$(way)\" \"\"","all clean ::","# Don't rely on -e working, instead we check exit return codes from sub-makes.","\t@case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \\","\tfor i in $(WAYS) ; do \\","\t echo \"== $(MAKE) way=$$i -f $(MAKEFILE) $@;\"; \\","\t $(MAKE) way=$$i -f $(MAKEFILE) --no-print-directory $(MFLAGS) $@ ; \\","\t if [ $$? -eq 0 ] ; then true; else exit $$x_on_err; fi; \\","\tdone","\t@echo \"== Finished recursively making \\`$@' for ways: $(WAYS) ...\"","endif","endif",""] -} diff --git a/Distribution/Simple/GHC/Makefile.in b/Distribution/Simple/GHC/Makefile.in deleted file mode 100644 --- a/Distribution/Simple/GHC/Makefile.in +++ /dev/null @@ -1,167 +0,0 @@ -# ----------------------------------------------------------------------------- -# Makefile template starts here. - -GHC_OPTS += -i$(odir) - -# For adding options on the command-line -GHC_OPTS += $(EXTRA_HC_OPTS) - -WAY_p_OPTS = -prof -WAY_dyn_OPTS = -fPIC -dynamic -WAY_dyn_CC_OPTS = -fPIC - -ifneq "$(way)" "" -way_ := $(way)_ -_way := _$(way) -GHC_OPTS += $(WAY_$(way)_OPTS) -GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf) -GHC_CC_OPTS += $(WAY_$(way)_CC_OPTS) -endif -osuf = $(way_)o -hisuf = $(way_)hi - -HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules))) -HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules))) -C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS)) - -ifeq "$(way:%dyn=YES)" "YES" -LIB = $(odir)/libHS$(package)$(_way:%_dyn=%)-ghc$(GHC_VERSION)$(soext) -else -LIB = $(odir)/libHS$(package)$(_way).a -endif - -RM = rm -f - -# Optionally include local customizations: --include Makefile.local - -# Rules follow: - -MKSTUBOBJS = find $(odir) -name "*_stub.$(osuf)" -print -# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to -# make using cached directory contents, or something. - -all :: $(odir)/.depend $(LIB) - -$(odir)/.depend : $(MAKEFILE) - $(GHC) -M -optdep-f -optdep$(odir)/.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules) - for dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \ - if test ! -d $$dir; then mkdir -p $$dir; fi \ - done - -include $(odir)/.depend - -ifeq "$(way:%dyn=YES)" "YES" -$(LIB) : $(HS_OBJS) $(C_OBJS) - @$(RM) $@ - $(GHC) -shared -dynamic -o $@ $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` $(LIB_LD_OPTS) -else -ifneq "$(filter -split-objs, $(GHC_OPTS))" "" -$(LIB) : $(HS_OBJS) $(C_OBJS) - @$(RM) $@ - (echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs $(AR) q $(EXTRA_AR_ARGS) $@ -else -$(LIB) : $(HS_OBJS) $(C_OBJS) - @$(RM) $@ - echo $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` | xargs $(AR) q $(EXTRA_AR_ARGS) $@ -endif -endif - -ifneq "$(GHCI_LIB)" "" -ifeq "$(way)" "" -all :: $(GHCI_LIB) - -$(GHCI_LIB) : $(HS_OBJS) $(C_OBJS) - @$(RM) $@ - $(LD) -r -o $@ $(EXTRA_LD_OPTS) $(HS_OBJS) `$(MKSTUBOBJS)` $(C_OBJS) -endif -endif - -# suffix rules - -ifneq "$(odir)" "" -odir_ = $(odir)/ -else -odir_ = -endif - -$(odir_)%.$(osuf) : $(srcdir)/%.hs - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) - -$(odir_)%.$(osuf) : $(srcdir)/%.lhs - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) - -# The .hs files might be in $(odir) if they were preprocessed -$(odir_)%.$(osuf) : $(odir_)%.hs - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) - -$(odir_)%.$(osuf) : $(odir_)%.lhs - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) - -$(odir_)%.$(osuf) : $(srcdir)/%.c - @$(RM) $@ - $(GHC) $(GHC_CC_OPTS) -c $< -o $@ - -$(odir_)%.$(osuf) : $(srcdir)/%.$(way_)s - @$(RM) $@ - $(GHC) $(GHC_CC_OPTS) -c $< -o $@ - -$(odir_)%.$(osuf) : $(srcdir)/%.S - @$(RM) $@ - $(GHC) $(GHC_CC_OPTS) -c $< -o $@ - -$(odir_)%.$(way_)s : $(srcdir)/%.c - @$(RM) $@ - $(GHC) $(GHC_CC_OPTS) -S $< -o $@ - -$(odir_)%.$(osuf)-boot : $(srcdir)/%.hs-boot - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot - -$(odir_)%.$(osuf)-boot : $(srcdir)/%.lhs-boot - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot - -%.$(hisuf) : %.$(osuf) - @if [ ! -f $@ ] ; then \ - echo Panic! $< exists, but $@ does not.; \ - exit 1; \ - else exit 0 ; \ - fi - -%.$(way_)hi-boot : %.$(osuf)-boot - @if [ ! -f $@ ] ; then \ - echo Panic! $< exists, but $@ does not.; \ - exit 1; \ - else exit 0 ; \ - fi - -$(odir_)%.$(hisuf) : %.$(way_)hc - @if [ ! -f $@ ] ; then \ - echo Panic! $< exists, but $@ does not.; \ - exit 1; \ - else exit 0 ; \ - fi - -show: - @echo '$(VALUE)="$($(VALUE))"' - -clean :: - $(RM) $(HS_OBJS) $(C_OBJS) $(LIB) $(GHCI_LIB) $(HS_IFS) .depend - $(RM) -rf $(wildcard $(patsubst %.$(osuf), %_split, $(HS_OBJS))) - $(RM) $(wildcard $(patsubst %.$(osuf), %.o-boot, $(HS_OBJS))) - $(RM) $(wildcard $(patsubst %.$(osuf), %.hi-boot, $(HS_OBJS))) - $(RM) $(wildcard $(patsubst %.$(osuf), %_stub.o, $(HS_OBJS))) - -ifneq "$(strip $(WAYS))" "" -ifeq "$(way)" "" -all clean :: -# Don't rely on -e working, instead we check exit return codes from sub-makes. - @case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \ - for i in $(WAYS) ; do \ - echo "== $(MAKE) way=$$i -f $(MAKEFILE) $@;"; \ - $(MAKE) way=$$i -f $(MAKEFILE) --no-print-directory $(MFLAGS) $@ ; \ - if [ $$? -eq 0 ] ; then true; else exit $$x_on_err; fi; \ - done - @echo "== Finished recursively making \`$@' for ways: $(WAYS) ..." -endif -endif - diff --git a/Distribution/Simple/GHC/mkGHCMakefile.sh b/Distribution/Simple/GHC/mkGHCMakefile.sh deleted file mode 100644 --- a/Distribution/Simple/GHC/mkGHCMakefile.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh -file=Makefile.hs -echo "-- DO NOT EDIT: change Makefile.in, and run ./mkGHCMakefile.sh" >$file -echo "module Distribution.Simple.GHC.Makefile where {" >>$file -echo "makefileTemplate :: String; makefileTemplate=unlines" >>$file -ghc -e "readFile \"Makefile.in\" >>= print . lines" >>$file -echo "}" >>$file diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs deleted file mode 100644 --- a/Distribution/Simple/Haddock.hs +++ /dev/null @@ -1,428 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Haddock --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Invokes haddock to generate api documentation for libraries and optinally --- executables in this package. Also has support for generating --- syntax-highlighted source with HsColour and linking the haddock docs to it. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Haddock ( - haddock, hscolour - ) where - --- local -import Distribution.Package - ( PackageIdentifier, Package(..) ) -import Distribution.PackageDescription as PD - (PackageDescription(..), BuildInfo(..), hcOptions, - Library(..), hasLibs, withLib, - Executable(..), withExe) -import Distribution.Simple.Compiler - ( Compiler(..), CompilerFlavor(..), compilerVersion - , extensionsToFlags ) -import Distribution.Simple.Program - ( ConfiguredProgram(..), requireProgram - , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout - , hscolourProgram, haddockProgram, ghcProgram ) -import Distribution.Simple.PreProcess (ppCpp', ppUnlit, preprocessSources, - PPSuffixHandler, runSimplePreProcessor) -import Distribution.Simple.Setup -import Distribution.Simple.Build (initialBuildSteps) -import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, - PathTemplateVariable(..), - toPathTemplate, fromPathTemplate, - substPathTemplate, - initialPathTemplateEnv) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths ( haddockPref, haddockName, - hscolourPref, autogenModulesDir ) -import qualified Distribution.Simple.PackageIndex as PackageIndex - ( lookupPackageId ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) -import Distribution.Simple.Utils - ( die, warn, notice, intercalate, setupMessage - , createDirectoryIfMissingVerbose, withTempFile - , findFileWithExtension, findFile, dotToSep ) -import Distribution.Text - ( display, simpleParse ) - -import Distribution.Verbosity -import Language.Haskell.Extension --- Base -import System.Directory(removeFile, doesFileExist, - removeDirectoryRecursive, copyFile) - -import Control.Monad ( when, unless ) -import Data.Maybe ( isJust, fromJust, listToMaybe ) -import Data.Char (isSpace) -import Data.List (nub) - -import System.FilePath((), (<.>), splitFileName, splitExtension, - replaceExtension, normalise) -import System.IO (hClose, hPutStrLn) -import Distribution.Version - --- -------------------------------------------------------------------------- --- Haddock support - -haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) = - warn (fromFlag $ haddockVerbosity haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the haddock command with the " - ++ "--executables." - -haddock pkg_descr lbi suffixes flags = do - let distPref = fromFlag (haddockDistPref flags) - doExes = fromFlag (haddockExecutables flags) - hsColour = fromFlag (haddockHscolour flags) - when hsColour $ hscolour pkg_descr lbi suffixes defaultHscolourFlags { - hscolourCSS = haddockHscolourCss flags, - hscolourExecutables = haddockExecutables flags, - hscolourVerbosity = haddockVerbosity flags - } - - (confHaddock, _) <- requireProgram verbosity haddockProgram - (orLaterVersion (Version [0,6] [])) (withPrograms lbi) - - let tmpDir = buildDir lbi "tmp" - createDirectoryIfMissingVerbose verbosity True tmpDir - createDirectoryIfMissingVerbose verbosity True $ - haddockPref distPref pkg_descr - preprocessSources pkg_descr lbi False verbosity suffixes - - setupMessage verbosity "Running Haddock for" (packageId pkg_descr) - - let replaceLitExts = map ( (tmpDir ) . (`replaceExtension` "hs") ) - let showPkg = display (packageId pkg_descr) - let hoogle = fromFlag (haddockHoogle flags) - outputFlag | hoogle = "--hoogle" - | otherwise = "--html" - let Just version = programVersion confHaddock - let have_src_hyperlink_flags = version >= Version [0,8] [] - isVersion2 = version >= Version [2,0] [] - - when (hoogle && version > Version [2] [] - && version < Version [2,2] []) $ - die $ "haddock 2.0 and 2.1 do not support the --hoogle flag." - - let mockFlags - | isVersion2 = [] - | otherwise = ["-D__HADDOCK__"] - - let mockAll bi = mapM_ (mockPP mockFlags bi tmpDir) - - let comp = compiler lbi - let cssFileFlag = case flagToMaybe $ haddockCss flags of - Nothing -> [] - Just cssFile -> ["--css=" ++ cssFile] - let verboseFlags = if verbosity >= deafening then ["--verbose"] else [] - when (hsColour && not have_src_hyperlink_flags) $ - die "haddock --hyperlink-source requires Haddock version 0.8 or later" - let linkToHscolour = if hsColour - then ["--source-module=src/%{MODULE/./-}.html" - ,"--source-entity=src/%{MODULE/./-}.html#%{NAME}"] - else [] - - let htmlTemplate = fmap toPathTemplate $ - flagToMaybe (haddockHtmlLocation flags) - packageFlags <- do - (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate - maybe (return ()) (warn verbosity) warnings - return packageFlags - - when isVersion2 $ do - strHadGhcVers <- rawSystemProgramStdout verbosity confHaddock ["--ghc-version"] - let mHadGhcVers :: Maybe Version - mHadGhcVers = simpleParse strHadGhcVers - when (mHadGhcVers == Nothing) $ die "Could not get GHC version from Haddock" - when (fromJust mHadGhcVers /= compilerVersion comp) $ - die "Haddock's internal GHC version must match the configured GHC version" - - ghcLibDir0 <- rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] - let ghcLibDir = reverse $ dropWhile isSpace $ reverse ghcLibDir0 - - let packageName = if isVersion2 - then ["--optghc=-package-name", "--optghc=" ++ showPkg] - else ["--package=" ++ showPkg] - - let haddock2options bi preprocessDir = if isVersion2 - then ("-B" ++ ghcLibDir) : map ("--optghc=" ++) (ghcSimpleOptions lbi bi preprocessDir) - else [] - - when isVersion2 $ - initialBuildSteps distPref pkg_descr lbi verbosity suffixes - - withLib pkg_descr () $ \lib -> do - let bi = libBuildInfo lib - modules = PD.exposedModules lib ++ otherModules bi - inFiles <- getLibSourceFiles lbi lib - unless isVersion2 $ mockAll bi inFiles - let template = showPkg ++ "-haddock-prolog.txt" - prolog | null (PD.description pkg_descr) = synopsis pkg_descr - | otherwise = PD.description pkg_descr - subtitle | null (synopsis pkg_descr) = "" - | otherwise = ": " ++ synopsis pkg_descr - titleComment | fromFlag (haddockInternal flags) = " (internal documentation)" - | otherwise = "" - withTempFile distPref template $ \prologFileName prologFileHandle -> do - hPutStrLn prologFileHandle prolog - hClose prologFileHandle - let targets - | isVersion2 = modules - | otherwise = replaceLitExts inFiles - let haddockFile = haddockPref distPref pkg_descr - haddockName pkg_descr - -- FIX: replace w/ rawSystemProgramConf? - let hideArgs | fromFlag (haddockInternal flags) = [] - | otherwise = map ("--hide=" ++) (otherModules bi) - let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"] - | otherwise = [] - rawSystemProgram verbosity confHaddock - ([ outputFlag - , "--odir=" ++ haddockPref distPref pkg_descr - , "--title=" ++ showPkg ++ subtitle ++ titleComment - , "--dump-interface=" ++ haddockFile - , "--prologue=" ++ prologFileName ] - ++ packageName - ++ cssFileFlag - ++ linkToHscolour - ++ packageFlags - ++ programArgs confHaddock - ++ verboseFlags - ++ hideArgs - ++ exportsFlags - ++ haddock2options bi (buildDir lbi) - ++ targets - ) - notice verbosity $ "Documentation created: " - ++ (haddockPref distPref pkg_descr "index.html") - - withExe pkg_descr $ \exe -> when doExes $ do - let bi = buildInfo exe - exeTargetDir = haddockPref distPref pkg_descr exeName exe - createDirectoryIfMissingVerbose verbosity True exeTargetDir - inFiles@(srcMainPath:_) <- getExeSourceFiles lbi exe - mockAll bi inFiles - let template = showPkg ++ "-haddock-prolog.txt" - prolog | null (PD.description pkg_descr) = synopsis pkg_descr - | otherwise = PD.description pkg_descr - titleComment | fromFlag (haddockInternal flags) = " (internal documentation)" - | otherwise = "" - withTempFile distPref template $ \prologFileName prologFileHandle -> do - hPutStrLn prologFileHandle prolog - hClose prologFileHandle - let targets - | isVersion2 = srcMainPath : otherModules bi - | otherwise = replaceLitExts inFiles - let preprocessDir = buildDir lbi exeName exe exeName exe ++ "-tmp" - let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"] - | otherwise = [] - rawSystemProgram verbosity confHaddock - ([ outputFlag - , "--odir=" ++ exeTargetDir - , "--title=" ++ exeName exe ++ titleComment - , "--prologue=" ++ prologFileName ] - ++ linkToHscolour - ++ packageFlags - ++ programArgs confHaddock - ++ verboseFlags - ++ exportsFlags - ++ haddock2options bi preprocessDir - ++ targets - ) - notice verbosity $ "Documentation created: " - ++ (exeTargetDir "index.html") - - removeDirectoryRecursive tmpDir - where - verbosity = fromFlag (haddockVerbosity flags) - mockPP inputArgs bi pref file - = do let (filePref, fileName) = splitFileName file - let targetDir = pref filePref - let targetFile = targetDir fileName - let (targetFileNoext, targetFileExt) = splitExtension targetFile - let cppOutput = targetFileNoext <.> "hspp" - let hsFile = targetFileNoext <.> "hs" - createDirectoryIfMissingVerbose verbosity True targetDir - -- Run unlit first, then CPP - if (targetFileExt == ".lhs") - then runSimplePreProcessor ppUnlit file hsFile verbosity - else copyFile file hsFile - when (needsCpp bi) $ do - runSimplePreProcessor (ppCpp' inputArgs bi lbi) - hsFile cppOutput verbosity - removeFile hsFile - copyFile cppOutput hsFile - removeFile cppOutput - needsCpp :: BuildInfo -> Bool - needsCpp bi = CPP `elem` extensions bi - -haddockPackageFlags :: LocalBuildInfo - -> Maybe PathTemplate - -> IO ([String], Maybe String) -haddockPackageFlags lbi htmlTemplate = do - interfaces <- sequence - [ case interfaceAndHtmlPath pkgid of - Nothing -> return (pkgid, Nothing) - Just (interface, html) -> do - exists <- doesFileExist interface - if exists - then return (pkgid, Just (interface, html)) - else return (pkgid, Nothing) - | pkgid <- packageDeps lbi ] - - let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map display missing) - flags = [ "--read-interface=" - ++ (if null html then "" else html ++ ",") ++ interface - | (_, Just (interface, html)) <- interfaces ] - - return (flags, if null missing then Nothing else Just warning) - - where - interfaceAndHtmlPath :: PackageIdentifier -> Maybe (FilePath, FilePath) - interfaceAndHtmlPath pkgId = do - pkg <- PackageIndex.lookupPackageId (installedPkgs lbi) pkgId - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- case htmlTemplate of - Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate) - return (interface, html) - - where expandTemplateVars = fromPathTemplate . substPathTemplate env - env = (PrefixVar, prefix (installDirTemplates lbi)) - : initialPathTemplateEnv pkgId (compilerId (compiler lbi)) - - -ghcSimpleOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] -ghcSimpleOptions lbi bi mockDir - = ["-hide-all-packages"] - ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) - ++ ["-i"] - ++ hcOptions GHC bi - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - ++ ["-i" ++ mockDir] - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ ["-odir", mockDir] - ++ ["-hidir", mockDir] - ++ extensionsToFlags c (extensions bi) - where c = compiler lbi - - --- -------------------------------------------------------------------------- --- hscolour support - -hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour pkg_descr lbi suffixes flags = do - let distPref = fromFlag $ hscolourDistPref flags - (hscolourProg, _) <- requireProgram verbosity hscolourProgram - (orLaterVersion (Version [1,8] [])) (withPrograms lbi) - - createDirectoryIfMissingVerbose verbosity True $ - hscolourPref distPref pkg_descr - preprocessSources pkg_descr lbi False verbosity suffixes - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - let replaceDot = map (\c -> if c == '.' then '-' else c) - - withLib pkg_descr () $ \lib -> when (isJust $ library pkg_descr) $ do - let bi = libBuildInfo lib - modules = PD.exposedModules lib ++ otherModules bi - outputDir = hscolourPref distPref pkg_descr "src" - createDirectoryIfMissingVerbose verbosity True outputDir - copyCSS hscolourProg outputDir - inFiles <- getLibSourceFiles lbi lib - flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> - let outFile = outputDir replaceDot mo <.> "html" - in rawSystemProgram verbosity hscolourProg - ["-css", "-anchor", "-o" ++ outFile, inFile] - - withExe pkg_descr $ \exe -> when doExes $ do - let bi = buildInfo exe - modules = "Main" : otherModules bi - outputDir = hscolourPref distPref pkg_descr exeName exe "src" - createDirectoryIfMissingVerbose verbosity True outputDir - copyCSS hscolourProg outputDir - inFiles <- getExeSourceFiles lbi exe - flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> - let outFile = outputDir replaceDot mo <.> "html" - in rawSystemProgram verbosity hscolourProg - ["-css", "-anchor", "-o" ++ outFile, inFile] - - where copyCSS hscolourProg dir = case stylesheet of - Nothing | programVersion hscolourProg >= Just (Version [1,9] []) -> - rawSystemProgram verbosity hscolourProg - ["-print-css", "-o" ++ dir "hscolour.css"] - | otherwise -> return () - Just s -> copyFile s (dir "hscolour.css") - doExes = fromFlag (hscolourExecutables flags) - stylesheet = flagToMaybe (hscolourCSS flags) - verbosity = fromFlag (hscolourVerbosity flags) - - -getLibSourceFiles :: LocalBuildInfo -> Library -> IO [FilePath] -getLibSourceFiles lbi lib = sequence - [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi) - (dotToSep module_) >>= maybe (notFound module_) (return . normalise) - | module_ <- modules ] - where - bi = libBuildInfo lib - modules = PD.exposedModules lib ++ otherModules bi - preprocessDir = buildDir lbi - notFound module_ = die $ "can't find source for module " ++ module_ - -getExeSourceFiles :: LocalBuildInfo -> Executable -> IO [FilePath] -getExeSourceFiles lbi exe = do - srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) - moduleFiles <- sequence - [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi) - (dotToSep module_) >>= maybe (notFound module_) (return . normalise) - | module_ <- modules ] - return (srcMainPath : moduleFiles) - where - bi = buildInfo exe - modules = otherModules bi - preprocessDir = buildDir lbi exeName exe exeName exe ++ "-tmp" - notFound module_ = die $ "can't find source for module " ++ module_ diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs deleted file mode 100644 --- a/Distribution/Simple/Hugs.hs +++ /dev/null @@ -1,398 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Hugs --- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Build and install functionality for Hugs. - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Hugs ( - configure, build, install - ) where - -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), hcOptions, - Executable(..), withExe, Library(..), withLib, libModules ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag ) -import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, - requireProgram, rawSystemProgramConf, - ffihugsProgram, hugsProgram ) -import Distribution.Version ( Version(..), VersionRange(AnyVersion) ) -import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) -import Distribution.Simple.PreProcess.Unlit - ( unlit ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..)) -import Distribution.Simple.BuildPaths - ( autogenModuleName, autogenModulesDir, - dllExtension ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, readUTF8File - , findFile, dotToSep, findFileWithExtension, smartCopySources - , die, info, notice ) -import Language.Haskell.Extension - ( Extension(..) ) -import System.FilePath ( (), takeExtension, (<.>), - searchPathSeparator, normalise, takeDirectory ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity - -import Data.Char ( isSpace ) -import Data.Maybe ( mapMaybe, catMaybes ) -import Control.Monad ( unless, when, filterM ) -import Control.Exception ( try ) -import Data.List ( nub, sort, isSuffixOf ) -import System.Directory ( Permissions(..), getPermissions, - setPermissions, copyFile, - removeDirectoryRecursive ) - - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram AnyVersion - (userMaybeSpecifyPath "ffihugs" hcPath conf) - (_hugsProg, conf'') <- requireProgram verbosity hugsProgram AnyVersion conf' - - let comp = Compiler { - compilerId = CompilerId Hugs (Version [] []), - compilerExtensions = hugsLanguageExtensions - } - return (comp, conf'') - --- | The flags for the supported extensions -hugsLanguageExtensions :: [(Extension, Flag)] -hugsLanguageExtensions = - [(OverlappingInstances , "+o") - ,(IncoherentInstances , "+oO") - ,(HereDocuments , "+H") - ,(TypeSynonymInstances , "-98") - ,(RecursiveDo , "-98") - ,(ParallelListComp , "-98") - ,(MultiParamTypeClasses , "-98") - ,(FunctionalDependencies , "-98") - ,(Rank2Types , "-98") - ,(PolymorphicComponents , "-98") - ,(ExistentialQuantification , "-98") - ,(ScopedTypeVariables , "-98") - ,(ImplicitParams , "-98") - ,(ExtensibleRecords , "-98") - ,(RestrictedTypeSynonyms , "-98") - ,(FlexibleContexts , "-98") - ,(FlexibleInstances , "-98") - ,(ForeignFunctionInterface , "") - ,(EmptyDataDecls , "") - ,(CPP , "") - ] - --- ----------------------------------------------------------------------------- --- Building - --- |Building a package for Hugs. -build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -build pkg_descr lbi verbosity = do - let pref = scratchDir lbi - createDirectoryIfMissingVerbose verbosity True pref - withLib pkg_descr () $ \ l -> do - copyFile (autogenModulesDir lbi paths_modulename) - (pref paths_modulename) - compileBuildInfo pref [] (libModules pkg_descr) (libBuildInfo l) - withExe pkg_descr $ compileExecutable (pref "programs") - where - srcDir = buildDir lbi - - paths_modulename = autogenModuleName pkg_descr ++ ".hs" - - compileExecutable :: FilePath -> Executable -> IO () - compileExecutable destDir (exe@Executable {modulePath=mainPath, buildInfo=bi}) = do - let exeMods = otherModules bi - srcMainFile <- findFile (hsSourceDirs bi) mainPath - let exeDir = destDir exeName exe - let destMainFile = exeDir hugsMainFilename exe - copyModule (CPP `elem` extensions bi) bi srcMainFile destMainFile - let destPathsFile = exeDir paths_modulename - copyFile (autogenModulesDir lbi paths_modulename) - destPathsFile - compileBuildInfo exeDir (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi - compileFiles bi exeDir [destMainFile, destPathsFile] - - compileBuildInfo :: FilePath -- ^output directory - -> [FilePath] -- ^library source dirs, if building exes - -> [String] -- ^Modules - -> BuildInfo -> IO () - compileBuildInfo destDir mLibSrcDirs mods bi = do - -- Pass 1: copy or cpp files from build directory to scratch directory - let useCpp = CPP `elem` extensions bi - let srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs - info verbosity $ "Source directories: " ++ show srcDirs - flip mapM_ mods $ \ m -> do - fs <- findFileWithExtension suffixes srcDirs (dotToSep m) - case fs of - Nothing -> - die ("can't find source for module " ++ m) - Just srcFile -> do - let ext = takeExtension srcFile - copyModule useCpp bi srcFile - (destDir dotToSep m <.> ext) - -- Pass 2: compile foreign stubs in scratch directory - stubsFileLists <- fmap catMaybes $ sequence - [ findFileWithExtension suffixes [destDir] (dotToSep modu) - | modu <- mods] - compileFiles bi destDir stubsFileLists - - suffixes = ["hs", "lhs"] - - -- Copy or cpp a file from the source directory to the build directory. - copyModule :: Bool -> BuildInfo -> FilePath -> FilePath -> IO () - copyModule cppAll bi srcFile destFile = do - createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) - (exts, opts, _) <- getOptionsFromSource srcFile - let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] - if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do - runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity - return () - else - copyFile srcFile destFile - - compileFiles :: BuildInfo -> FilePath -> [FilePath] -> IO () - compileFiles bi modDir fileList = do - ffiFileList <- filterM testFFI fileList - unless (null ffiFileList) $ do - notice verbosity "Compiling FFI stubs" - mapM_ (compileFFI bi modDir) ffiFileList - - -- Only compile FFI stubs for a file if it contains some FFI stuff - testFFI :: FilePath -> IO Bool - testFFI file = do - inp <- readHaskellFile file - return ("foreign" `elem` symbols (stripComments False inp)) - - compileFFI :: BuildInfo -> FilePath -> FilePath -> IO () - compileFFI bi modDir file = do - (_, opts, file_incs) <- getOptionsFromSource file - let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] - let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi] - let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs)) - let pathFlag = "-P" ++ modDir ++ [searchPathSeparator] - let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs - cfiles <- getCFiles file - let cArgs = - ["-I" ++ dir | dir <- includeDirs bi] ++ - ccOptions bi ++ - cfiles ++ - ["-L" ++ dir | dir <- extraLibDirs bi] ++ - ldOptions bi ++ - ["-l" ++ lib | lib <- extraLibs bi] ++ - concat [["-framework", f] | f <- frameworks bi] - rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi) - (hugsArgs ++ file : cArgs) - - includeOpts :: [String] -> [String] - includeOpts [] = [] - includeOpts ("-#include" : arg : opts) = arg : includeOpts opts - includeOpts (_ : opts) = includeOpts opts - - -- get C file names from CFILES pragmas throughout the source file - getCFiles :: FilePath -> IO [String] - getCFiles file = do - inp <- readHaskellFile file - return [normalise cfile | - "{-#" : "CFILES" : rest <- - map words $ lines $ stripComments True inp, - last rest == "#-}", - cfile <- init rest] - - -- List of terminal symbols in a source file. - symbols :: String -> [String] - symbols cs = case lex cs of - (sym, cs'):_ | not (null sym) -> sym : symbols cs' - _ -> [] - - -- Get the non-literate source of a Haskell module. - readHaskellFile :: FilePath -> IO String - readHaskellFile file = do - text <- readUTF8File file - if ".lhs" `isSuffixOf` file - then either return die (unlit file text) - else return text - --- ------------------------------------------------------------ --- * options in source files --- ------------------------------------------------------------ - --- |Read the initial part of a source file, before any Haskell code, --- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas. -getOptionsFromSource - :: FilePath - -> IO ([Extension], -- LANGUAGE pragma, if any - [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas - [String] -- INCLUDE pragmas - ) -getOptionsFromSource file = do - text <- readUTF8File file - text' <- if ".lhs" `isSuffixOf` file - then either return die (unlit file text) - else return text - return $ foldr appendOptions ([],[],[]) $ map getOptions $ - takeWhileJust $ map getPragma $ - filter textLine $ map (dropWhile isSpace) $ lines $ - stripComments True text' - where textLine [] = False - textLine ('#':_) = False - textLine _ = True - - getPragma :: String -> Maybe [String] - getPragma line = case words line of - ("{-#" : rest) | last rest == "#-}" -> Just (init rest) - _ -> Nothing - - getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], []) - getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], []) - getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], []) - getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], []) - getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], []) - where readExtension :: String -> Maybe Extension - readExtension w = case reads w of - [(ext, "")] -> Just ext - [(ext, ",")] -> Just ext - _ -> Nothing - getOptions ("INCLUDE":ws) = ([], [], ws) - getOptions _ = ([], [], []) - - appendOptions (exts, opts, incs) (exts', opts', incs') - = (exts++exts', opts++opts', incs++incs') - --- takeWhileJust f = map fromJust . takeWhile isJust -takeWhileJust :: [Maybe a] -> [a] -takeWhileJust (Just x:xs) = x : takeWhileJust xs -takeWhileJust _ = [] - --- |Strip comments from Haskell source. -stripComments - :: Bool -- ^ preserve pragmas? - -> String -- ^ input source text - -> String -stripComments keepPragmas = stripCommentsLevel 0 - where stripCommentsLevel :: Int -> String -> String - stripCommentsLevel 0 ('"':cs) = '"':copyString cs - stripCommentsLevel 0 ('-':'-':cs) = -- FIX: symbols like --> - stripCommentsLevel 0 (dropWhile (/= '\n') cs) - stripCommentsLevel 0 ('{':'-':'#':cs) - | keepPragmas = '{' : '-' : '#' : copyPragma cs - stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs - stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs - stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs - stripCommentsLevel n (_:cs) = stripCommentsLevel n cs - stripCommentsLevel _ [] = [] - - copyString ('\\':c:cs) = '\\' : c : copyString cs - copyString ('"':cs) = '"' : stripCommentsLevel 0 cs - copyString (c:cs) = c : copyString cs - copyString [] = [] - - copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs - copyPragma (c:cs) = c : copyPragma cs - copyPragma [] = [] - --- ----------------------------------------------------------------------------- --- |Install for Hugs. --- For install, copy-prefix = prefix, but for copy they're different. --- The library goes in \\/lib\/hugs\/packages\/\ --- (i.e. \\/lib\/hugs\/packages\/\ on the target system). --- Each executable goes in \\/lib\/hugs\/programs\/\ --- (i.e. \\/lib\/hugs\/programs\/\ on the target system) --- with a script \\/bin\/\ pointing at --- \\/lib\/hugs\/programs\/\. -install - :: Verbosity -- ^verbosity - -> FilePath -- ^Library install location - -> FilePath -- ^Program install location - -> FilePath -- ^Executable install location - -> FilePath -- ^Program location on target system - -> FilePath -- ^Build location - -> (FilePath,FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> IO () -install verbosity libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do - try $ removeDirectoryRecursive libDir - smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes - let buildProgDir = buildPref "programs" - when (any (buildable . buildInfo) (executables pkg_descr)) $ - createDirectoryIfMissingVerbose verbosity True binDir - withExe pkg_descr $ \ exe -> do - let theBuildDir = buildProgDir exeName exe - let installDir = installProgDir exeName exe - let targetDir = targetProgDir exeName exe - try $ removeDirectoryRecursive installDir - smartCopySources verbosity [theBuildDir] installDir - ("Main" : autogenModuleName pkg_descr : otherModules (buildInfo exe)) hugsInstallSuffixes - let targetName = "\"" ++ (targetDir hugsMainFilename exe) ++ "\"" - -- FIX (HUGS): use extensions, and options from file too? - -- see http://hackage.haskell.org/trac/hackage/ticket/43 - let hugsOptions = hcOptions Hugs (buildInfo exe) - let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix - let exeFile = case buildOS of - Windows -> binDir baseExeFile <.> ".bat" - _ -> binDir baseExeFile - let script = case buildOS of - Windows -> - let args = hugsOptions ++ [targetName, "%*"] - in unlines ["@echo off", - unwords ("runhugs" : args)] - _ -> - let args = hugsOptions ++ [targetName, "\"$@\""] - in unlines ["#! /bin/sh", - unwords ("runhugs" : args)] - writeFile exeFile script - perms <- getPermissions exeFile - setPermissions exeFile perms { executable = True, readable = True } - -hugsInstallSuffixes :: [String] -hugsInstallSuffixes = [".hs", ".lhs", dllExtension] - --- |Filename used by Hugs for the main module of an executable. --- This is a simple filename, so that Hugs will look for any auxiliary --- modules it uses relative to the directory it's in. -hugsMainFilename :: Executable -> FilePath -hugsMainFilename exe = "Main" <.> ext - where ext = takeExtension (modulePath exe) diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs deleted file mode 100644 --- a/Distribution/Simple/Install.hs +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Install --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Perform the \"@.\/setup install@\" and \"@.\/setup --- copy@\" actions. Move files into place based on the prefix --- argument. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Install ( - install, - ) where - -import Distribution.PackageDescription ( - PackageDescription(..), BuildInfo(..), Library(..), - hasLibs, withLib, hasExes, withExe ) -import Distribution.Package (Package(..)) -import Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, - substPathTemplate) -import Distribution.Simple.BuildPaths (haddockName, haddockPref) -import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, - copyFileVerbose, die, info, notice, - copyDirectoryRecursiveVerbose) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag) - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.NHC as NHC -import qualified Distribution.Simple.JHC as JHC -import qualified Distribution.Simple.Hugs as Hugs - -import Control.Monad (when, unless) -import System.Directory (doesDirectoryExist, doesFileExist) -import System.FilePath - ( takeFileName, takeDirectory, (), isAbsolute ) - -import Distribution.Verbosity - --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. FIX: --- nhc isn't implemented yet. - -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () -install pkg_descr lbi flags = do - let distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest' flags) - InstallDirs { - bindir = binPref, - libdir = libPref, - dynlibdir = dynlibPref, - datadir = dataPref, - progdir = progPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref, - includedir = incPref - } = absoluteInstallDirs pkg_descr lbi copydest - - progPrefixPref = substPathTemplate pkg_descr lbi (progPrefix lbi) - progSuffixPref = substPathTemplate pkg_descr lbi (progSuffix lbi) - - docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr - info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ - " does exist: " ++ show docExists) - flip mapM_ (dataFiles pkg_descr) $ \ file -> do - let dir = takeDirectory file - createDirectoryIfMissingVerbose verbosity True (dataPref dir) - copyFileVerbose verbosity (dataDir pkg_descr file) (dataPref file) - when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - copyDirectoryRecursiveVerbose verbosity - (haddockPref distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - copyFileVerbose verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest - - let lfile = licenseFile pkg_descr - unless (null lfile) $ do - createDirectoryIfMissingVerbose verbosity True docPref - copyFileVerbose verbosity lfile (docPref takeFileName lfile) - - let buildPref = buildDir lbi - when (hasLibs pkg_descr) $ - notice verbosity ("Installing: " ++ libPref) - when (hasExes pkg_descr) $ - notice verbosity ("Installing: " ++ binPref) - - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref - - case compilerFlavor (compiler lbi) of - GHC -> do withLib pkg_descr () $ \_ -> - GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ \_ -> - GHC.installExe verbosity lbi binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr - JHC -> do withLib pkg_descr () $ JHC.installLib verbosity libPref buildPref pkg_descr - withExe pkg_descr $ JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr - Hugs -> do - let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest) - let scratchPref = scratchDir lbi - Hugs.install verbosity libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr - NHC -> do withLib pkg_descr () $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr) - withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) - _ -> die ("only installing with GHC, JHC, Hugs or nhc98 is implemented") - return () - -- register step should be performed by caller. - --- | Install the files listed in install-includes -installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installIncludeFiles verbosity PackageDescription{library=Just l} incdir - = do - incs <- mapM (findInc relincdirs) (installIncludes lbi) - unless (null incs) $ do - createDirectoryIfMissingVerbose verbosity True incdir - sequence_ [ copyFileVerbose verbosity path (incdir f) - | (f,path) <- incs ] - where - relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - lbi = libBuildInfo l - - findInc [] f = die ("can't find include file " ++ f) - findInc (d:ds) f = do - let path = (d f) - b <- doesFileExist path - if b then return (f,path) else findInc ds f -installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs deleted file mode 100644 --- a/Distribution/Simple/InstallDirs.hs +++ /dev/null @@ -1,548 +0,0 @@ -{-# OPTIONS -cpp -fffi #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_GHC -cpp -fffi #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.InstallDirs --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Definition of the 'LocalBuildInfo' data type. This is basically --- the information that is gathered by the end of the configuration --- step which could include package information from ghc-pkg, flags --- the user passed to configure, and the location of tools in the --- PATH. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.InstallDirs ( - InstallDirs(..), - InstallDirTemplates, - defaultInstallDirs, - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - - PathTemplate, - PathTemplateVariable(..), - toPathTemplate, - fromPathTemplate, - substPathTemplate, - initialPathTemplateEnv, - ) where - - -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) -import System.Directory (getAppUserDataDirectory) -import System.FilePath ((), isPathSeparator, pathSeparator) -#if __HUGS__ || __GLASGOW_HASKELL__ > 606 -import System.FilePath (dropDrive) -#endif - -import Distribution.Package - ( PackageIdentifier, packageName, packageVersion ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Compiler - ( CompilerId, CompilerFlavor(..) ) -import Distribution.Text - ( display ) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -import Foreign -import Foreign.C -#endif - --- --------------------------------------------------------------------------- --- Instalation directories - - --- | The directories where we will install files for packages. --- --- We have several different directories for different types of files since --- many systems have conventions whereby different types of files in a package --- are installed in different direcotries. This is particularly the case on --- unix style systems. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - libexecdir :: dir, - progdir :: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir - } deriving (Read, Show) - -instance Functor InstallDirs where - fmap f dirs = InstallDirs { - prefix = f (prefix dirs), - bindir = f (bindir dirs), - libdir = f (libdir dirs), - libsubdir = f (libsubdir dirs), - dynlibdir = f (dynlibdir dirs), - libexecdir = f (libexecdir dirs), - progdir = f (progdir dirs), - includedir = f (includedir dirs), - datadir = f (datadir dirs), - datasubdir = f (datasubdir dirs), - docdir = f (docdir dirs), - mandir = f (mandir dirs), - htmldir = f (htmldir dirs), - haddockdir = f (haddockdir dirs) - } - -instance Monoid dir => Monoid (InstallDirs dir) where - mempty = InstallDirs { - prefix = mempty, - bindir = mempty, - libdir = mempty, - libsubdir = mempty, - dynlibdir = mempty, - libexecdir = mempty, - progdir = mempty, - includedir = mempty, - datadir = mempty, - datasubdir = mempty, - docdir = mempty, - mandir = mempty, - htmldir = mempty, - haddockdir = mempty - } - mappend = combineInstallDirs mappend - -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - libsubdir = libsubdir a `combine` libsubdir b, - dynlibdir = dynlibdir a `combine` dynlibdir b, - libexecdir = libexecdir a `combine` libexecdir b, - progdir = progdir a `combine` progdir b, - includedir = includedir a `combine` includedir b, - datadir = datadir a `combine` datadir b, - datasubdir = datasubdir a `combine` datasubdir b, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b - } - -appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } - --- | The installation dirctories in terms of 'PathTemplate's that contain --- variables. --- --- The defaults for most of the directories are relative to each other, in --- particular they are all relative to a single prefix. This makes it --- convenient for the user to override the default installation directory --- by only having to specify --prefix=... rather than overriding each --- individually. This is done by allowing $-style variables in the dirs. --- These are expanded by textual substituion (see 'substPathTemplate'). --- --- A few of these installation directories are split into two components, the --- dir and subdir. The full installation path is formed by combining the two --- together with @\/@. The reason for this is compatability with other unix --- build systems which also support @--libdir@ and @--datadir@. We would like --- users to be able to configure @--libdir=\/usr\/lib64@ for example but --- because by default we want to support installing multiplve versions of --- packages and building the same package for multiple compilers we append the --- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@. --- --- An additional complication is the need to support relocatable packages on --- systems which support such things, like Windows. --- -type InstallDirTemplates = InstallDirs PathTemplate - --- --------------------------------------------------------------------------- --- Default installation directories - -defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs comp userInstall hasLibs = do - windowsProgramFilesDir <- getWindowsProgramFilesDir - userInstallPrefix <- getAppUserDataDirectory "cabal" - return $ fmap toPathTemplate $ InstallDirs { - prefix = if userInstall - then userInstallPrefix - else case buildOS of - Windows -> windowsProgramFilesDir "Haskell" - _other -> "/usr/local", - bindir = "$prefix" "bin", - libdir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "lib", - libsubdir = case comp of - Hugs -> "hugs" "packages" "$pkg" - JHC -> "$compiler" - _other -> "$pkgid" "$compiler", - dynlibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$pkgid" - _other -> "$prefix" "libexec", - progdir = "$libdir" "hugs" "programs", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows | hasLibs -> windowsProgramFilesDir "Haskell" - | otherwise -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$pkgid", - docdir = case buildOS of - Windows -> "$prefix" "doc" "$pkgid" - _other -> "$datadir" "doc" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir" - } - --- --------------------------------------------------------------------------- --- Converting directories, absolute or prefix-relative - --- | Substitute the install dir templates into each other. --- --- To prevent cyclic substitutions, only some variables are allowed in --- particular dir templates. If out of scope vars are present, they are not --- substituted for. Checking for any remaining unsubstituted vars can be done --- as a subsequent operation. --- --- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we --- can replace 'prefix' with the 'PrefixVar' and get resulting --- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it --- each to check which paths are relative to the $prefix. --- -substituteTemplates :: PackageIdentifier -> CompilerId - -> InstallDirTemplates -> InstallDirTemplates -substituteTemplates pkgId compilerId dirs = dirs' - where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - libsubdir = subst libsubdir [], - dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], - libexecdir = subst libexecdir prefixBinLibVars, - progdir = subst progdir prefixBinLibVars, - includedir = subst includedir prefixBinLibVars, - datadir = subst datadir prefixBinLibVars, - datasubdir = subst datasubdir [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst docdir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]) - } - -- The initial environment has all the static stuff but no paths - env = initialPathTemplateEnv pkgId compilerId - subst dir env' = substPathTemplate (env'++env) (dir dirs) - - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') - prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] - prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] - --- | Convert from abstract install directories to actual absolute ones by --- substituting for all the variables in the abstract paths, to get real --- absolute path. -absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest - -> InstallDirTemplates -> InstallDirs FilePath -absoluteInstallDirs pkgId compilerId copydest dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteTemplates pkgId compilerId dirs { - prefix = case copydest of - -- possibly override the prefix - CopyPrefix p -> toPathTemplate p - _ -> prefix dirs - } - --- |The location prefix for the /copy/ command. -data CopyDest - = NoCopyDest - | CopyTo FilePath - | CopyPrefix FilePath -- DEPRECATED - deriving (Eq, Show) - --- | Check which of the paths are relative to the installation $prefix. --- --- If any of the paths are not relative, ie they are absolute paths, then it --- prevents us from making a relocatable package (also known as a \"prefix --- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkgId compilerId dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map - -- \$prefix back to $prefix. We're trying to end up with templates that - -- mention no vars except $prefix. - substituteTemplates pkgId compilerId dirs { - prefix = PathTemplate [Variable PrefixVar] - } - where - -- If it starts with $prefix then it's relative and produce the relative - -- path by stripping off $prefix/ or $prefix - relative dir = case dir of - PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') - relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing - --- --------------------------------------------------------------------------- --- Path templates - --- | An abstract path, posibly containing variables that need to be --- substituted for to get a real 'FilePath'. --- -newtype PathTemplate = PathTemplate [PathComponent] - -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | PkgNameVar -- ^ The @$pkg@ package name path variable - | PkgVerVar -- ^ The @$version@ package version path variable - | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ - deriving Eq - --- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- -toPathTemplate :: FilePath -> PathTemplate -toPathTemplate = PathTemplate . read - --- | Convert back to a path, any remaining vars are included --- -fromPathTemplate :: PathTemplate -> FilePath -fromPathTemplate (PathTemplate template) = show template - -combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate -combinePathTemplate (PathTemplate t1) (PathTemplate t2) = - PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) - -substPathTemplate :: [(PathTemplateVariable, PathTemplate)] - -> PathTemplate -> PathTemplate -substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] - --- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier -> CompilerId - -> [(PathTemplateVariable, PathTemplate)] -initialPathTemplateEnv pkgId compilerId = - map (\(v,s) -> (v, PathTemplate [Ordinary s])) - [(PkgNameVar, packageName pkgId) - ,(PkgVerVar, display (packageVersion pkgId)) - ,(PkgIdVar, display pkgId) - ,(CompilerVar, display compilerId)] - --- --------------------------------------------------------------------------- --- Parsing and showing path templates: - --- The textual format is that of an ordinary Haskell String, eg --- "$prefix/bin" --- and this gets parsed to the internal representation as a sequence of path --- spans which are either strings or variables, eg: --- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] - -instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DatadirVar = "datadir" - show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - -instance Read PathTemplateVariable where - readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar)] - -instance Show PathComponent where - show (Ordinary path) = path - show (Variable var) = '$':show var - showList = foldr (\x -> (shows x .)) id - -instance Read PathComponent where - -- for some reason we colapse multiple $ symbols here - readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] - -instance Show PathTemplate where - show (PathTemplate template) = show (show template) - -instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] - --- --------------------------------------------------------------------------- --- Internal utilities - -getWindowsProgramFilesDir :: IO FilePath -getWindowsProgramFilesDir = do -#if mingw32_HOST_OS || mingw32_TARGET_OS - m <- shGetFolderPath csidl_PROGRAM_FILES -#else - let m = Nothing -#endif - return (fromMaybe "C:\\Program Files" m) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -shGetFolderPath :: CInt -> IO (Maybe FilePath) -shGetFolderPath n = -# if __HUGS__ - return Nothing -# else - allocaBytes long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath - if (r /= 0) - then return Nothing - else do s <- peekCString pPath; return (Just s) - where - long_path_size = 1024 -# endif - -csidl_PROGRAM_FILES :: CInt -csidl_PROGRAM_FILES = 0x0026 --- csidl_PROGRAM_FILES_COMMON :: CInt --- csidl_PROGRAM_FILES_COMMON = 0x002b - -foreign import stdcall unsafe "shlobj.h SHGetFolderPathA" - c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CString - -> IO CInt -#endif - -#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) --- Compat: this function only appears in FilePath > 1.0 --- (which at the time of writing is unreleased) -dropDrive :: FilePath -> FilePath -dropDrive (c:cs) | isPathSeparator c = cs -dropDrive (_:':':c:cs) | isWindows - && isPathSeparator c = cs -- path with drive letter -dropDrive (_:':':cs) | isWindows = cs -dropDrive cs = cs - -isWindows :: Bool -isWindows = case buildOS of - Windows -> True - _ -> False -#endif diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs deleted file mode 100644 --- a/Distribution/Simple/JHC.hs +++ /dev/null @@ -1,188 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.JHC --- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Build and install functionality for the JHC compiler. - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.JHC ( - configure, getInstalledPackages, build, installLib, installExe - ) where - -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), - withLib, - Executable(..), withExe, Library(..), - libModules, hcOptions ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, emptyInstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(package) ) -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths - ( autogenModulesDir, exeExtension ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , PackageDB, Flag, extensionsToFlags ) -import Language.Haskell.Extension (Extension(..)) -import Distribution.Simple.Program ( ConfiguredProgram(..), jhcProgram, - ProgramConfiguration, userMaybeSpecifyPath, - requireProgram, lookupProgram, - rawSystemProgram, rawSystemProgramStdoutConf ) -import Distribution.Version ( VersionRange(AnyVersion) ) -import Distribution.Package - ( Package(..) ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, copyFileVerbose - , die, info, intercalate ) -import System.FilePath ( () ) -import Distribution.Verbosity -import Distribution.Text - ( Text(parse), display ) -import Distribution.Compat.ReadP - ( readP_to_S, many, skipSpaces ) - -import Data.List ( nub ) -import Data.Char ( isSpace ) - - - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (jhcProg, conf') <- requireProgram verbosity jhcProgram AnyVersion - (userMaybeSpecifyPath "jhc" hcPath conf) - - let Just version = programVersion jhcProg - comp = Compiler { - compilerId = CompilerId JHC version, - compilerExtensions = jhcLanguageExtensions - } - return (comp, conf') - --- | The flags for the supported extensions -jhcLanguageExtensions :: [(Extension, Flag)] -jhcLanguageExtensions = - [(TypeSynonymInstances , "") - ,(ForeignFunctionInterface , "") - ,(NoImplicitPrelude , "--noprelude") - ,(CPP , "-fcpp") - ] - -getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration - -> IO (PackageIndex InstalledPackageInfo) -getInstalledPackages verbosity _packagedb conf = do - str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] - case pCheck (readP_to_S (many (skipSpaces >> parse)) str) of - [ps] -> return $ PackageIndex.fromList - [ emptyInstalledPackageInfo { - InstalledPackageInfo.package = p - } - | p <- ps ] - _ -> die "cannot parse package list" - where - pCheck :: [(a, [Char])] -> [a] - pCheck rs = [ r | (r,s) <- rs, all isSpace s ] - --- ----------------------------------------------------------------------------- --- Building - --- | Building a package for JHC. --- Currently C source files are not supported. -build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -build pkg_descr lbi verbosity = do - let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) - withLib pkg_descr () $ \lib -> do - info verbosity "Building library..." - let libBi = libBuildInfo lib - let args = constructJHCCmdLine lbi libBi (buildDir lbi) verbosity - rawSystemProgram verbosity jhcProg (["-c"] ++ args ++ libModules pkg_descr) - let pkgid = display (packageId pkg_descr) - pfile = buildDir lbi "jhc-pkg.conf" - hlfile= buildDir lbi (pkgid ++ ".hl") - writeFile pfile $ jhcPkgConf pkg_descr - rawSystemProgram verbosity jhcProg ["--build-hl="++pfile, "-o", hlfile] - withExe pkg_descr $ \exe -> do - info verbosity ("Building executable "++exeName exe) - let exeBi = buildInfo exe - let out = buildDir lbi exeName exe - let args = constructJHCCmdLine lbi exeBi (buildDir lbi) verbosity - rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) - -constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath -> Verbosity -> [String] -constructJHCCmdLine lbi bi _odir verbosity = - (if verbosity >= deafening then ["-v"] else []) - ++ extensionsToFlags (compiler lbi) (extensions bi) - ++ hcOptions JHC bi - ++ ["--noauto","-i-"] - ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] - ++ ["-i", autogenModulesDir lbi] - ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] - ++ (concat [ ["-p", display pkg] | pkg <- packageDeps lbi ]) - -jhcPkgConf :: PackageDescription -> String -jhcPkgConf pd = - let sline name sel = name ++ ": "++sel pd - Just lib = library pd - comma = intercalate "," - in unlines [sline "name" (display . packageId) - ,"exposed-modules: " ++ (comma (PD.exposedModules lib)) - ,"hidden-modules: " ++ (comma (otherModules $ libBuildInfo lib)) - ] - -installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () -installLib verb dest build_dir pkg_descr _ = do - let p = display (packageId pkg_descr)++".hl" - createDirectoryIfMissingVerbose verb True dest - copyFileVerbose verb (build_dir p) (dest p) - -installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () -installExe verb dest build_dir (progprefix,progsuffix) _ exe = do - let exe_name = exeName exe - src = exe_name exeExtension - out = (progprefix ++ exe_name ++ progsuffix) exeExtension - createDirectoryIfMissingVerbose verb True dest - copyFileVerbose verb (build_dir src) (dest out) - diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs deleted file mode 100644 --- a/Distribution/Simple/LocalBuildInfo.hs +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.LocalBuildInfo --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Definition of the 'LocalBuildInfo' data type. This is basically --- the information that is gathered by the end of the configuration --- step which could include package information from ghc-pkg, flags --- the user passed to configure, and the location of tools in the --- PATH. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - substPathTemplate, - - -- * Deprecated compat stuff - mkDataDir, - ) where - - -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.Setup (CopyDest(..)) -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.PackageDescription (PackageDescription(..)) -import Distribution.Package (PackageIdentifier, Package(..)) -import Distribution.Simple.Compiler - ( Compiler(..), PackageDB, OptimisationLevel ) -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) - --- |Data cached after configuration step. See also --- 'Distribution.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various differnt - -- kinds of files - compiler :: Compiler, - -- ^ The compiler we're building with - buildDir :: FilePath, - -- ^ Where to build the package. - scratchDir :: FilePath, - -- ^ Where to put the result of the Hugs build. - packageDeps :: [PackageIdentifier], - -- ^ Which packages we depend on, /exactly/. - -- The 'Distribution.PackageDescription.PackageDescription' - -- 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. - installedPkgs :: PackageIndex InstalledPackageInfo, - -- ^ All the info about all installed packages. - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ The resolved package description, that does not contain - -- any conditionals. - withPrograms :: ProgramConfiguration, -- ^Location and args for all programs - withPackageDB :: PackageDB, -- ^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. - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables - - } deriving (Read, Show) - --- ----------------------------------------------------------------------------- --- Wrappers for a couple functions from InstallDirs - --- |See 'InstallDirs.absoluteInstallDirs' -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest - -> InstallDirs FilePath -absoluteInstallDirs pkg_descr lbi copydest = - InstallDirs.absoluteInstallDirs - (packageId pkg_descr) - (compilerId (compiler lbi)) - copydest - (installDirTemplates lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeInstallDirs :: PackageDescription -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkg_descr lbi = - InstallDirs.prefixRelativeInstallDirs - (packageId pkg_descr) - (compilerId (compiler lbi)) - (installDirTemplates lbi) - -substPathTemplate :: PackageDescription -> LocalBuildInfo - -> PathTemplate -> FilePath -substPathTemplate pkg_descr lbi = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - (packageId pkg_descr) - (compilerId (compiler lbi)) - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -mkDataDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath -mkDataDir pkg_descr lbi copydest = - datadir (absoluteInstallDirs pkg_descr lbi copydest) -{-# DEPRECATED mkDataDir "use datadir :: InstallDirs -> FilePath" #-} diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs deleted file mode 100644 --- a/Distribution/Simple/NHC.hs +++ /dev/null @@ -1,256 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.NHC --- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.NHC - ( configure - , build - , installLib, installExe - ) where - -import Distribution.Package - ( PackageIdentifier, packageName, Package(..) ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..), - withLib, withExe, hcOptions ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths - ( mkLibName, objExtension, exeExtension ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , Flag, extensionsToFlags ) -import Language.Haskell.Extension - ( Extension(..) ) -import Distribution.Simple.Program - ( ProgramConfiguration, userMaybeSpecifyPath, requireProgram, - lookupProgram, ConfiguredProgram(programVersion), programPath, - nhcProgram, hmakeProgram, ldProgram, arProgram, - rawSystemProgramConf ) -import Distribution.Simple.Utils - ( die, info, findFileWithExtension, dotToSep, - createDirectoryIfMissingVerbose, copyFileVerbose, smartCopySources ) -import Distribution.Version - ( Version(..), VersionRange(..), orLaterVersion ) -import Distribution.Verbosity -import System.FilePath - ( (), (<.>), normalise, takeDirectory, dropExtension ) -import System.Directory - ( removeFile ) - -import Control.Exception (try) -import Data.List ( nub ) -import Control.Monad ( when, unless ) - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (nhcProg, conf') <- requireProgram verbosity nhcProgram - (orLaterVersion (Version [1,20] [])) - (userMaybeSpecifyPath "nhc98" hcPath conf) - let Just nhcVersion = programVersion nhcProg - - (_hmakeProg, conf'') <- requireProgram verbosity hmakeProgram - (orLaterVersion (Version [3,13] [])) conf' - (_ldProg, conf''') <- requireProgram verbosity ldProgram AnyVersion conf'' - (_arProg, conf'''') <- requireProgram verbosity arProgram AnyVersion conf''' - - --TODO: put this stuff in a monad so we can say just: - -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] [])) - -- requireProgram ldProgram AnyVersion - -- requireProgram ldPrograrProgramam AnyVersion - -- unless (null (cSources bi)) $ requireProgram ccProgram AnyVersion - - let comp = Compiler { - compilerId = CompilerId NHC nhcVersion, - compilerExtensions = nhcLanguageExtensions - } - return (comp, conf'''') - --- | The flags for the supported extensions -nhcLanguageExtensions :: [(Extension, Flag)] -nhcLanguageExtensions = - -- TODO: use -98 when no extensions are specified. - -- NHC doesn't enforce the monomorphism restriction at all. - [(NoMonomorphismRestriction, "") - ,(ForeignFunctionInterface, "") - ,(ExistentialQuantification, "") - ,(EmptyDataDecls, "") - ,(NamedFieldPuns, "-puns") - ,(CPP, "-cpp") - ] - --- ----------------------------------------------------------------------------- --- Building - --- |FIX: For now, the target must contain a main module. Not used --- ATM. Re-add later. -build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -build pkg_descr lbi verbosity = do - let conf = withPrograms lbi - Just nhcProg = lookupProgram nhcProgram conf - withLib pkg_descr () $ \lib -> do - let bi = libBuildInfo lib - modules = exposedModules lib ++ otherModules bi - -- Unsupported extensions have already been checked by configure - extensionFlags = extensionsToFlags (compiler lbi) (extensions bi) - inFiles <- getModulePaths lbi bi modules - let targetDir = buildDir lbi - srcDirs = nub (map takeDirectory inFiles) - destDirs = map (targetDir ) srcDirs - mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs - rawSystemProgramConf verbosity hmakeProgram conf $ - ["-hc=" ++ programPath nhcProg] - ++ nhcVerbosityOptions verbosity - ++ ["-d", targetDir, "-hidir", targetDir] - ++ extensionFlags - ++ maybe [] (hcOptions NHC . libBuildInfo) - (library pkg_descr) - ++ concat [ ["-package", packageName pkg] | pkg <- packageDeps lbi ] - ++ inFiles -{- - -- build any C sources - unless (null (cSources bi)) $ do - info verbosity "Building C Sources..." - let commonCcArgs = (if verbosity >= deafening then ["-v"] else []) - ++ ["-I" ++ dir | dir <- includeDirs bi] - ++ [opt | opt <- ccOptions bi] - ++ (if withOptimization lbi then ["-O2"] else []) - flip mapM_ (cSources bi) $ \cfile -> do - let ofile = targetDir cfile `replaceExtension` objExtension - createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile) - rawSystemProgramConf verbosity hmakeProgram conf - (commonCcArgs ++ ["-c", cfile, "-o", ofile]) --} - -- link: - info verbosity "Linking..." - let --cObjs = [ targetDir cFile `replaceExtension` objExtension - -- | cFile <- cSources bi ] - libFilePath = targetDir mkLibName (packageId pkg_descr) - hObjs = [ targetDir dotToSep m <.> objExtension - | m <- modules ] - - unless (null hObjs {-&& null cObjs-}) $ do - try (removeFile libFilePath) -- first remove library if it exists - - let arVerbosity | verbosity >= deafening = "v" - | verbosity >= normal = "" - | otherwise = "c" - - rawSystemProgramConf verbosity arProgram (withPrograms lbi) $ - ["q"++ arVerbosity, libFilePath] - ++ hObjs --- ++ cObjs - - withExe pkg_descr $ \exe -> do - when (dropExtension (modulePath exe) /= exeName exe) $ - die $ "hmake does not support exe names that do not match the name of " - ++ "the 'main-is' file. You will have to rename your executable to " - ++ show (dropExtension (modulePath exe)) - let bi = buildInfo exe - modules = otherModules bi - -- Unsupported extensions have already been checked by configure - extensionFlags = extensionsToFlags (compiler lbi) (extensions bi) - inFiles <- getModulePaths lbi bi modules - let targetDir = buildDir lbi exeName exe - exeDir = targetDir (exeName exe ++ "-tmp") - srcDirs = nub (map takeDirectory (modulePath exe : inFiles)) - destDirs = map (exeDir ) srcDirs - mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs - rawSystemProgramConf verbosity hmakeProgram conf $ - ["-hc=" ++ programPath nhcProg] - ++ nhcVerbosityOptions verbosity - ++ ["-d", targetDir, "-hidir", targetDir] - ++ extensionFlags - ++ maybe [] (hcOptions NHC . libBuildInfo) - (library pkg_descr) - ++ concat [ ["-package", packageName pkg] | pkg <- packageDeps lbi ] - ++ inFiles - ++ [exeName exe] - -nhcVerbosityOptions :: Verbosity -> [String] -nhcVerbosityOptions verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-q"] - ---TODO: where to put this? it's duplicated in .Simple too -getModulePaths :: LocalBuildInfo -> BuildInfo -> [String] -> IO [FilePath] -getModulePaths lbi bi modules = sequence - [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi) - (dotToSep module_) >>= maybe (notFound module_) (return . normalise) - | module_ <- modules ] - where notFound module_ = die $ "can't find source for module " ++ module_ - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHC. -installExe :: Verbosity -- ^verbosity - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> Executable - -> IO () -installExe verbosity pref buildPref (progprefix,progsuffix) exe - = do createDirectoryIfMissingVerbose verbosity True pref - let exeBaseName = exeName exe - exeFileName = exeBaseName <.> exeExtension - fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension - copyFileVerbose verbosity (buildPref exeBaseName exeFileName) - (pref fixedExeFileName) - --- |Install for nhc98: .hi and .a files -installLib :: Verbosity -- ^verbosity - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageIdentifier - -> Library - -> IO () -installLib verbosity pref buildPref pkgid lib - = do let bi = libBuildInfo lib - modules = exposedModules lib ++ otherModules bi - smartCopySources verbosity [buildPref] pref modules ["hi"] - let libName = mkLibName pkgid - copyFileVerbose verbosity (buildPref libName) (pref libName) diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs deleted file mode 100644 --- a/Distribution/Simple/PackageIndex.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : Duncan Coutts --- Stability : provisional --- Portability : portable --- --- An index of packages. ------------------------------------------------------------------------------ -module Distribution.Simple.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - - -- ** Bulk queries - allPackages, - allPackagesByName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - ) where - -import Prelude hiding (lookup) -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Tree as Tree -import qualified Data.Graph as Graph -import qualified Data.Array as Array -import Data.Array ((!)) -import Data.List (groupBy, sortBy, find) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isNothing, fromMaybe) - -import Distribution.Package - ( PackageIdentifier, Package(..), packageName, packageVersion - , Dependency(Dependency), PackageFixedDeps(..) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf) - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) -import Text.Read -import qualified Text.Read.Lex as L -#endif - --- | The collection of information about packages from one or more 'PackageDB's. --- --- It can be searched effeciently by package name and version. --- -data Package pkg => PackageIndex pkg = PackageIndex - -- This index maps lower case package names to all the - -- 'InstalledPackageInfo' records matching that package name - -- case-insensitively. It includes all versions. - -- - -- This allows us to do case sensitive or insensitive lookups, and to find - -- all versions satisfying a dependency, all by varying how we filter. So - -- most queries will do a map lookup followed by a linear scan of the bucket. - -- - (Map String [pkg]) - -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) - deriving (Show, Read) -#else --- The Show/Read instance for Data.Map in ghc-6.4 is useless --- so we have to re-implement it here: -instance (Package pkg, Show pkg) => Show (PackageIndex pkg) where - showsPrec d (PackageIndex m) = - showParen (d > 10) (showString "PackageIndex" . shows (Map.toList m)) - -instance (Package pkg, Read pkg) => Read (PackageIndex pkg) where - readPrec = parens $ prec 10 $ do - Ident "PackageIndex" <- lexP - xs <- readPrec - return (PackageIndex (Map.fromList xs)) - where parens :: ReadPrec a -> ReadPrec a - parens p = optional - where - optional = p +++ mandatory - mandatory = paren optional - - paren :: ReadPrec a -> ReadPrec a - paren p = do L.Punc "(" <- lexP - x <- reset p - L.Punc ")" <- lexP - return x - - readListPrec = readListPrecDefault -#endif - -instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex (Map.empty) - mappend = merge - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = foldr1 mappend xs - -invariant :: Package pkg => PackageIndex pkg -> Bool -invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) - where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 - where - check pkgid [] = lowercase (packageName pkgid) == name - check pkgid (pkg':pkgs) = lowercase (packageName pkgid) == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' - -mkPackageIndex :: Package pkg => Map String [pkg] -> PackageIndex pkg -mkPackageIndex index = assert (invariant (PackageIndex index)) - (PackageIndex index) - -internalError :: String -> a -internalError name = error ("PackageIndex." ++ name ++ ": internal error") - --- | Lookup a name in the index to get all packages that match that name --- case-insensitively. --- -lookup :: Package pkg => PackageIndex pkg -> String -> [pkg] -lookup (PackageIndex m) name = - case Map.lookup (lowercase name) m of - Nothing -> [] - Just pkgs -> pkgs - --- | Build an index out of a bunch of 'Package's. --- --- If there are duplicates, later ones mask earlier ones. --- -fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ let key = (lowercase . packageName) pkg - in (key, [pkg]) - | pkg <- pkgs ] - where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) - --- | Merge two indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -merge i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - --- | Elements in the second list mask those in the first. -mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - let key = (lowercase . packageName) pkg - in Map.insertWith (\_ -> insertNoDup) key [pkg] index - where - pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' - GT -> pkg' : insertNoDup pkgs' - --- | Internal delete helper. --- -delete :: Package pkg => String -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - let key = lowercase name - in Map.update filterBucket key index - where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing - deleteEmptyBucket remaining = Just remaining - --- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg -deletePackageId pkgid = - delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => String -> PackageIndex pkg -> PackageIndex pkg -deletePackageName name = - delete name (\pkg -> packageName pkg == name) - --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg -deleteDependency (Dependency name verstionRange) = - delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) - --- | Get all the packages from the index. --- -allPackages :: Package pkg => PackageIndex pkg -> [pkg] -allPackages (PackageIndex m) = concat (Map.elems m) - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = - concatMap (groupBy (equating packageName)) (Map.elems m) - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insentiviely to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insentiviely but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insentiviely and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] -searchByName index name = - case groupBy (equating packageName) (lookup index name) of - [] -> None - [pkgs] -> Unambiguous pkgs - pkgss -> case find ((name==) . packageName . head) pkgss of - Just pkgs -> Unambiguous pkgs - Nothing -> Ambiguous pkgss - -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 :: Package pkg => PackageIndex pkg -> String -> [pkg] -searchByNameSubstring (PackageIndex m) searchterm = - [ pkg - | (name, pkgs) <- Map.toList m - , searchterm' `isInfixOf` name - , pkg <- pkgs ] - where searchterm' = lowercase searchterm - --- | Does a lookup by package id (name & version). --- --- Since multiple package DBs mask each other case-sensitively by package name, --- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg -lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing - [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" - --- | Does a case-sensitive search by package name. --- -lookupPackageName :: Package pkg => PackageIndex pkg -> String -> [pkg] -lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] - --- | Does a case-sensitive search by package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] -lookupDependency index (Dependency name versionRange) = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] - --- | All packages that have dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageFixedDeps pkg - => PackageIndex pkg - -> [(pkg, [PackageIdentifier])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- depends pkg - , isNothing (lookupPackageId index pkg') ] - , not (null missing) ] - --- | Tries to take the transative closure of the package dependencies. --- --- If the transative closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageIdentifier's do not occur in the index. --- -dependencyClosure :: PackageFixedDeps pkg - => PackageIndex pkg - -> [PackageIdentifier] - -> Either (PackageIndex pkg) - [(pkg, [PackageIdentifier])] -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 lookupPackageId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupPackageId completed (packageId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = depends pkg ++ pkgids - --- | Takes the transative closure of the packages reverse dependencies. --- --- * The given 'PackageIdentifier's must be in the index. --- -reverseDependencyClosure :: PackageFixedDeps pkg - => PackageIndex pkg - -> [PackageIdentifier] - -> [PackageIdentifier] -reverseDependencyClosure index = - map vertexToPkgId - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - - where - (depGraph, vertexToPkgId, pkgIdToVertex) = dependencyGraph index - reverseDepGraph = Graph.transposeG depGraph - noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies :: PackageFixedDeps pkg - => PackageIndex pkg - -> [(String, [(PackageIdentifier, Version)])] -dependencyInconsistencies index = - [ (name, inconsistencies) - | (name, uses) <- Map.toList inverseIndex - , let inconsistencies = duplicatesBy uses - , not (null inconsistencies) ] - - where inverseIndex = Map.fromListWith (++) - [ (packageName dep, [(packageId pkg, packageVersion dep)]) - | pkg <- allPackages index - , dep <- depends pkg ] - - duplicatesBy = (\groups -> if length groups == 1 - then [] - else concat groups) - . groupBy (equating snd) - . sortBy (comparing snd) - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: PackageFixedDeps pkg - => PackageIndex pkg - -> [[pkg]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, packageId pkg, depends pkg) - | pkg <- allPackages index ] - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageFixedDeps pkg - => PackageIndex pkg - -> (Graph.Graph, - Graph.Vertex -> PackageIdentifier, - PackageIdentifier -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertexToPkgId, pkgIdToVertex) - where - graph = Array.listArray bounds - [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] - | pkg <- pkgs ] - vertexToPkgId vertex = pkgIdTable ! vertex - pkgIdToVertex = binarySearch 0 topBound - - pkgIdTable = Array.listArray bounds (map packageId pkgs) - pkgs = sortBy (comparing packageId) (allPackages index) - topBound = length pkgs - 1 - bounds = (0, topBound) - - binarySearch a b key - | a > b = Nothing - | otherwise = case compare key (pkgIdTable ! mid) of - LT -> binarySearch a (mid-1) key - EQ -> Just mid - GT -> binarySearch (mid+1) b key - where mid = (a + b) `div` 2 diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs deleted file mode 100644 --- a/Distribution/Simple/PreProcess.hs +++ /dev/null @@ -1,463 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- --- PreProcessors are programs or functions which input a filename and --- output a Haskell file. The general form of a preprocessor is input --- Foo.pp and output Foo.hs (where /pp/ is a unique extension that --- tells us which preprocessor to use eg. gc, ly, cpphs, x, y, etc.). --- Once a PreProcessor has been added to Cabal, either here or with --- 'Distribution.Simple.UserHooks', if Cabal finds a Foo.pp, it'll run the given --- preprocessor which should output a Foo.hs. - -{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.PreProcess (preprocessSources, knownSuffixHandlers, - ppSuffixes, PPSuffixHandler, PreProcessor(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit - ) - where - - -import Distribution.Simple.PreProcess.Unlit (unlit) -import Distribution.PackageDescription (PackageDescription(..), - BuildInfo(..), Executable(..), withExe, - Library(..), withLib, libModules) -import Distribution.Package - ( Package(..) ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.BuildPaths (autogenModulesDir) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File - , die, setupMessage, intercalate, copyFileVerbose - , findFileWithExtension, findFileWithExtension', dotToSep ) -import Distribution.Simple.Program (Program(..), ConfiguredProgram(..), - lookupProgram, programPath, - rawSystemProgramConf, rawSystemProgram, - greencardProgram, cpphsProgram, hsc2hsProgram, - c2hsProgram, happyProgram, alexProgram, - haddockProgram, ghcProgram) -import Distribution.Version (Version(..)) -import Distribution.Verbosity -import Distribution.Text - ( display, simpleParse ) - -import Control.Monad (when, unless, join) -import Data.Maybe (fromMaybe) -import System.Directory (getModificationTime, doesFileExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess --- --- We split the input and output file names into a base directory and the --- rest of the file name. The input base dir is the path in the list of search --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. --- --- The reason for splitting it up this way is that some pre-processors don't --- simply generate one output .hs file from one input file but have --- dependencies on other genereated files (notably c2hs, where building one --- .hs file may require reading other .chi files, and then compiling the .hs --- file may require reading a generated .h file). In these cases the generated --- files need to embed relative path names to each other (eg the generated .hs --- file mentions the .h file in the FFI imports). This path must be relative to --- the base directory where the genereated files are located, it cannot be --- relative to the top level of the build tree because the compilers do not --- look for .h files relative to there, ie we do not use \"-I .\", instead we --- use \"-I dist\/build\" (or whatever dist dir has been set by the user) --- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. --- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- inlcuded into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementaion dependent output - -- eg alex and happy have --ghc flags. However we can't really inlcude - -- ghc-specific code into supposedly portable source tarballs. - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails - } - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) - --- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain --- a Haskell source file for each module. -preprocessSources :: PackageDescription - -> LocalBuildInfo - -> Bool -- ^ Build for SDist - -> Verbosity -- ^ verbosity - -> [PPSuffixHandler] -- ^ preprocessors to try - -> IO () - -preprocessSources pkg_descr lbi forSDist verbosity handlers = do - withLib pkg_descr () $ \ lib -> do - setupMessage verbosity "Preprocessing library" (packageId pkg_descr) - let bi = libBuildInfo lib - let biHandlers = localHandlers bi - sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist - modu verbosity builtinSuffixes biHandlers - | modu <- libModules pkg_descr] - unless (null (executables pkg_descr)) $ - setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr) - withExe pkg_descr $ \ theExe -> do - let bi = buildInfo theExe - let biHandlers = localHandlers bi - let exeDir = buildDir lbi exeName theExe exeName theExe ++ "-tmp" - sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist - modu verbosity builtinSuffixes biHandlers - | modu <- otherModules bi] - preprocessModule (hsSourceDirs bi) exeDir forSDist - (dropExtensions (modulePath theExe)) - verbosity builtinSuffixes biHandlers - where hc = compilerFlavor (compiler lbi) - builtinSuffixes - | hc == NHC = ["hs", "lhs", "gc"] - | otherwise = ["hs", "lhs"] - localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] - --- |Find the first extension of the file that exists, and preprocess it --- if required. -preprocessModule - :: [FilePath] -- ^source directories - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> String -- ^module name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> IO () -preprocessModule searchLoc buildLoc forSDist modu verbosity builtinSuffixes handlers = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc (dotToSep modu) - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc (dotToSep modu) - case bsrcFiles of - Nothing -> die ("can't find source for " ++ modu ++ " in " - ++ intercalate ", " searchLoc) - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Internal error in preProcess module: Just expected") - (lookup (tailNotNull ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - 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] (dotToSep modu) - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> do - btime <- getModificationTime ppsrcFile - ptime <- getModificationTime psrcFile - return (btime < ptime) - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessor pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") verbosity - - where dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x - --- ------------------------------------------------------------ --- * known preprocessors --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppGreenCard _ lbi - = PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - --- This one is useful for preprocessors that can't handle literate source. --- We also need a way to chain preprocessors. -ppUnlit :: PreProcessor -ppUnlit = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> do - contents <- readUTF8File inFile - either (writeUTF8File outFile) die (unlit inFile contents) - } - -ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp' extraArgs bi lbi = - case compilerFlavor (compiler lbi) of - GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi - _ -> ppCpphs (cppArgs ++ extraArgs) bi lbi - - where cppArgs = sysDefines ++ cppOptions bi ++ getCppOptions bi lbi - sysDefines = - ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] ++ - ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] - locations = ["BUILD", "HOST"] - -ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppGhcCpp extraArgs _bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgram verbosity ghcProg $ - ["-E", "-cpp"] - -- This is a bit of an ugly hack. We're going to - -- unlit the file ourselves later on if appropriate, - -- so we need GHC not to unlit it now or it'll get - -- double-unlitted. In the future we might switch to - -- using cpphs --unlit instead. - ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else []) - ++ (if use_optP_P lbi then ["-optP-P"] else []) - ++ ["-o", outFile, inFile] - ++ extraArgs - } - where Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) - Just ghcVersion = programVersion ghcProg - -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpphs extraArgs _bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity cpphsProgram (withPrograms lbi) $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : extraArgs - } - --- Haddock versions before 0.8 choke on #line and #file pragmas. Those --- pragmas are necessary for correct links when we preprocess. So use --- -optP-P only if the Haddock version is prior to 0.8. -use_optP_P :: LocalBuildInfo -> Bool -use_optP_P lbi - = case lookupProgram haddockProgram (withPrograms lbi) of - Just (ConfiguredProgram { programVersion = Just version }) - | version >= Version [0,8] [] -> False - _ -> True - -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi = pp - where pp = standardPP lbi hsc2hsProgram flags - flags = case fmap versionTags . join . fmap programVersion - . lookupProgram hsc2hsProgram . withPrograms $ lbi of - -- Just to make things complicated, the hsc2hs bundled with - -- ghc uses ghc as the C compiler, so to pass C flags we - -- have to use an additional layer of escaping. Grrr. - Just ["ghc"] -> - let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) - in [ "--cc=" ++ programPath ghcProg - , "--ld=" ++ programPath ghcProg ] - ++ -- Don't magically link in haskell98, rts and base - -- This is particularly important during the GHC build - -- itself, as they might not exist yet - ( case (programVersion ghcProg, simpleParse "6.9") of - (Just v1, Just v2) - | v1 >= v2 -> [ "--lflag=-no-auto-link-packages" ] - _ -> [] - ) - ++ [ "--cflag=-optc" ++ opt | opt <- ccOptions bi - ++ cppOptions bi ] - ++ [ "--cflag=" ++ opt | pkg <- packageDeps lbi - , opt <- ["-package" - ,display pkg] ] - ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi] - ++ [ "--lflag=-optl" ++ opt | opt <- getLdOptions bi ] - - _ -> [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] - ++ [ "--cflag=" ++ opt | opt <- ccOptions bi ] - ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi ] - ++ [ "--lflag=" ++ opt | opt <- getLdOptions bi ] - -getLdOptions :: BuildInfo -> [String] -getLdOptions bi = map ("-L" ++) (extraLibDirs bi) - ++ map ("-l" ++) (extraLibs bi) - ++ ldOptions bi - -ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppC2hs bi lbi - = PreProcessor { - platformIndependent = False, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> - rawSystemProgramConf verbosity c2hsProgram (withPrograms lbi) $ - ["--include=" ++ outBaseDir] - ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] - ++ ["--output-dir=" ++ outBaseDir, - "--output=" ++ outRelativeFile, - inBaseDir inRelativeFile] - } - -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = hcDefines (compiler lbi) - ++ ["-I" ++ dir | dir <- includeDirs bi] - ++ [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"] - -hcDefines :: Compiler -> [String] -hcDefines comp = - case compilerFlavor comp of - GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] - JHC -> ["-D__JHC__=" ++ versionInt version] - NHC -> ["-D__NHC__=" ++ versionInt version] - Hugs -> ["-D__HUGS__"] - _ -> [] - where version = compilerVersion comp - --- TODO: move this into the compiler abstraction --- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other --- compilers. Check if that's really what they want. -versionInt :: Version -> String -versionInt (Version { versionBranch = [] }) = "1" -versionInt (Version { versionBranch = [n] }) = show n -versionInt (Version { versionBranch = n1:n2:_ }) - = show n1 ++ take 2 ('0' : show n2) - -ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHappy _ lbi = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppAlex _ lbi = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags _ = [] - -standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor -standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - do rawSystemProgramConf verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - -- XXX This is a 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, e.g. - -- by preprocessing all files, with and "id" preprocessor if - -- nothing else, so the hs-boot files automatically get copied - -- into the right place. - -- Possibly we should also be looking for .lhs-boot files, but - -- I think that preprocessors only produce .hs files. - let inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - } - --- |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) - ] diff --git a/Distribution/Simple/PreProcess/Unlit.hs b/Distribution/Simple/PreProcess/Unlit.hs deleted file mode 100644 --- a/Distribution/Simple/PreProcess/Unlit.hs +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess.Unlit --- Copyright : ... --- --- Maintainer : Malcolm Wallace --- Stability : Stable --- Portability : portable --- --- Remove the \"literal\" markups from a Haskell source file, including --- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" - --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Data.Char -import Data.List - -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String - --- | No unliteration. -plain :: String -> String -> String -plain _ hs = hs - -classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file:_) | all isDigit line - && length file >= 2 - && head file == '"' - && last file == '"' - -> Line (read line) (tail (init file)) - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) - | s `isPrefixOf` "begin{code}" = BeginCode - | s `isPrefixOf` "end{code}" = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s - --- So the weird exception for comment indenting is to make things work with --- haddock, see classifyAndCheckForBirdTracks below. -unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError - --- | 'unlit' takes a filename (for error reports), and transforms the --- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> Either String String -unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - - where - -- So haddock requires comments and code to align, since it treats comments - -- as following the layout rule. This is a pain for us since bird track - -- style literate code typically gets indented by two since ">" is replaced - -- by " " and people usually use one additional space of indent ie - -- "> then the code". On the other hand we cannot just go and indent all - -- the comments by two since that does not work for latex style literate - -- code. So the hacky solution we use here is that if we see any bird track - -- style code then we'll indent all comments by two, otherwise by none. - -- Of course this will not work for mixed latex/bird track .lhs files but - -- nobody does that, it's silly and specifically recommended against in the - -- H98 unlit spec. - -- - classifyAndCheckForBirdTracks = - flip mapAccumL False $ \seenBirdTrack line -> - let classification = classify line - in (seenBirdTrack || isBirdTrack classification, classification) - - isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False - - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls - --- Here we model a state machine, with each state represented by --- a local function. We only have four states (well, five, --- if you count the error state), but the rules --- to transition between then are not so simple. --- Would it be simpler to have more states? --- --- Each state represents the type of line that was last read --- i.e. are we in a comment section, or a latex-code section, --- or a bird-code section, etc? -reclassify :: [Classified] -> [Classified] -reclassify = blank -- begin in blank state - where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls - - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls - - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls - - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] - -- a blank line and another ordinary line following a comment - -- will be treated as continuing the comment. Otherwise it's - -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. -inlines :: String -> [String] -inlines xs = lines' xs id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) - -internalError :: a -internalError = error "unlit: internal error" diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs deleted file mode 100644 --- a/Distribution/Simple/Program.hs +++ /dev/null @@ -1,645 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program --- Copyright : Isaac Jones 2006 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC, Hugs --- --- Explanation: A program is basically a name, a location, and some --- arguments. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also good default behavior for trying to find \"foo\" in --- PATH, being able to override its location, etc. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , simpleProgram - , findProgramOnPath - , findProgramVersion - - -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , rawSystemProgram - , rawSystemProgramStdout - - -- * The collection of unconfigured and configured progams - , builtinPrograms - - -- * The collection of configured programs we can run - , ProgramConfiguration - , emptyProgramConfiguration - , defaultProgramConfiguration - , addKnownProgram - , lookupKnownProgram - , knownPrograms - , userSpecifyPath - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifiedArgs - , lookupProgram - , updateProgram - , configureAllKnownPrograms - , requireProgram - , rawSystemProgramConf - , rawSystemProgramStdoutConf - - -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , nhcProgram - , hmakeProgram - , jhcProgram - , hugsProgram - , ffihugsProgram - , ranlibProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - ) where - -import qualified Data.Map as Map -import Distribution.Simple.Utils (die, debug, warn, rawSystemExit, - rawSystemStdout, rawSystemStdout', - withTempFile) -import Distribution.Version - ( Version(..), VersionRange(AnyVersion), withinRange ) -import Distribution.Text - ( simpleParse, display ) -import Distribution.Verbosity -import System.Directory (doesFileExist, removeFile, findExecutable, - getTemporaryDirectory) -import System.FilePath (dropExtension) -import System.IO (hClose) -import System.IO.Error (try) -import Control.Monad (join, foldM) -import Control.Exception as Exception (catch) - --- | Represents a program which can be configured. -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if it's location was not - -- specified by the user. Usually this will just be a - programFindLocation :: Verbosity -> IO (Maybe FilePath), - - -- | Try to find the version of the program. For many programs this is - -- not possible or is not necessary so it's ok to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) - } - -type ProgArg = String - -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. - programArgs :: [ProgArg], - - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation - } deriving (Read, Show) - --- | Where a program was found. Also tells us whether it's specifed by user or --- not. This includes not just the path, but the program as well. -data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The location of the program, as located by searching PATH. - deriving (Read, Show) - --- ------------------------------------------------------------ --- * Programs functions --- ------------------------------------------------------------ - --- | The full path of a configured program. -programPath :: ConfiguredProgram -> FilePath -programPath = locationPath . programLocation - --- | Make a simple named program. --- --- By default we'll just search for it in the path and not try to find the --- version name. You can override these behaviours if necessary, eg: --- --- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } --- -simpleProgram :: String -> Program -simpleProgram name = - Program name (findProgramOnPath name) (\_ _ -> return Nothing) - --- | Look for a program on the path. -findProgramOnPath :: FilePath -> Verbosity -> IO (Maybe FilePath) -findProgramOnPath prog verbosity = do - debug verbosity $ "searching for " ++ prog ++ " in path." - res <- findExecutable prog - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) - return res - --- | Look for a program and try to find it's version number. It can accept --- either an absolute path or the name of a program binary, in which case we --- will look for the program on the path. --- -findProgramVersion :: ProgArg -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) -findProgramVersion versionArg selectVersion verbosity path = do - str <- rawSystemStdout verbosity path [versionArg] - `Exception.catch` \_ -> return "" - let version :: Maybe Version - version = simpleParse (selectVersion str) - case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ display v - return version - --- ------------------------------------------------------------ --- * Programs database --- ------------------------------------------------------------ - --- | The configuration is a collection of information about programs. It --- contains information both about configured programs and also about programs --- that we are yet to configure. --- --- The idea is that we start from a collection of unconfigured programs and one --- by one we try to configure them at which point we move them into the --- configured collection. For unconfigured programs we record not just the --- 'Program' but also any user-provided arguments and location for the program. -data ProgramConfiguration = ProgramConfiguration { - unconfiguredProgs :: UnconfiguredProgs, - configuredProgs :: ConfiguredProgs - } -type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - -emptyProgramConfiguration :: ProgramConfiguration -emptyProgramConfiguration = ProgramConfiguration Map.empty Map.empty - -defaultProgramConfiguration :: ProgramConfiguration -defaultProgramConfiguration = - foldl (flip addKnownProgram) emptyProgramConfiguration builtinPrograms - --- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramConfiguration -> ProgramConfiguration -updateUnconfiguredProgs update conf = - conf { unconfiguredProgs = update (unconfiguredProgs conf) } -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramConfiguration -> ProgramConfiguration -updateConfiguredProgs update conf = - conf { configuredProgs = update (configuredProgs conf) } - --- Read & Show instances are based on listToFM --- Note that we only serialise the configured part of the database, this is --- because we don't need the unconfigured part after the configure stage, and --- additionally because we cannot read/show 'Program' as it contains functions. -instance Show ProgramConfiguration where - show = show . Map.toAscList . configuredProgs - -instance Read ProgramConfiguration where - readsPrec p s = - [ (emptyProgramConfiguration { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] - --- ------------------------------- --- Managing unconfigured programs - --- | Add a known program that we may configure later -addKnownProgram :: Program -> ProgramConfiguration -> ProgramConfiguration -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insert (programName prog) (prog, Nothing, []) - -lookupKnownProgram :: String -> ProgramConfiguration -> Maybe Program -lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - -knownPrograms :: ProgramConfiguration -> [(Program, Maybe ConfiguredProgram)] -knownPrograms conf = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) - , let p' = Map.lookup (programName p) (configuredProgs conf) ] - --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramConfiguration -> ProgramConfiguration -userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) - -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramConfiguration -> ProgramConfiguration -userMaybeSpecifyPath _ Nothing conf = conf -userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramConfiguration - -> ProgramConfiguration -userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programArgs = programArgs prog ++ args' }) - -userSpecifiedPath :: Program -> ProgramConfiguration -> Maybe FilePath -userSpecifiedPath prog = - join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs - -userSpecifiedArgs :: Program -> ProgramConfiguration -> [ProgArg] -userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - --- ----------------------------- --- Managing configured programs - --- | Try to find a configured program -lookupProgram :: Program -> ProgramConfiguration -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs - --- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramConfiguration - -> ProgramConfiguration -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - --- --------------------------- --- Configuring known programs - --- | Try to configure a specific program. If the program is already included in --- the colleciton of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured sucessfully it gets --- added to the configured collection. --- --- Note that it is not a failure if the program cannot be configured. It's only --- a failure if the user supplied a location and the program could not be found --- at that location. --- --- The reason for it not being a failure at this stage is that we don't know up --- front all the programs we will need, so we try to configure them all. --- To verify that a program was actually sucessfully configured use --- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramConfiguration - -> IO ProgramConfiguration -configureProgram verbosity prog conf = do - let name = programName prog - maybeLocation <- case userSpecifiedPath prog conf of - Nothing -> programFindLocation prog verbosity - >>= return . fmap FoundOnSystem - Just path -> do - absolute <- doesFileExist path - if absolute - then return (Just (UserSpecified path)) - else findProgramOnPath path verbosity - >>= maybe (die notFound) (return . Just . UserSpecified) - where notFound = "Cannot find " ++ name ++ " at " - ++ path ++ " or on the path" - case maybeLocation of - Nothing -> return conf - Just location -> do - version <- programFindVersion prog verbosity (locationPath location) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programArgs = userSpecifiedArgs prog conf, - programLocation = location - } - return (updateConfiguredProgs (Map.insert name configuredProg) conf) - --- | Try to configure all the known programs that have not yet been configured. -configureAllKnownPrograms :: Verbosity - -> ProgramConfiguration - -> IO ProgramConfiguration -configureAllKnownPrograms verbosity conf = - foldM (flip (configureProgram verbosity)) conf - [ prog | (prog,_,_) <- Map.elems (unconfiguredProgs conf - `Map.difference` configuredProgs conf) ] - --- | Check that a program is configured and available to be run. --- --- Additionally check that the version of the program number is suitable. --- For example 'AnyVersion' or @'orLaterVersion' ('Version' [1,0] [])@ --- --- It raises an exception if the program could not be configured or the version --- is unsuitable, otherwise it returns the configured program. -requireProgram :: Verbosity -> Program -> VersionRange -> ProgramConfiguration - -> IO (ConfiguredProgram, ProgramConfiguration) -requireProgram verbosity prog range conf = do - - -- If it's not already been configured, try to configure it now - conf' <- case lookupProgram prog conf of - Nothing -> configureProgram verbosity prog conf - Just _ -> return conf - - case lookupProgram prog conf' of - Nothing -> die notFound - Just configuredProg - | range == AnyVersion -> return (configuredProg, conf') - Just configuredProg@ConfiguredProgram { programLocation = location } -> - case programVersion configuredProg of - Just version - | withinRange version range -> return (configuredProg, conf') - | otherwise -> die (badVersion version location) - Nothing -> die (noVersion location) - - where notFound = programName prog ++ versionRequirement - ++ " is required but it could not be found." - badVersion v l = programName prog ++ versionRequirement - ++ " is required but the version found at " - ++ locationPath l ++ " is version " ++ display v - noVersion l = programName prog ++ versionRequirement - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | range == AnyVersion = "" - | otherwise = " version " ++ display range - --- ------------------------------------------------------------ --- * Running programs --- ------------------------------------------------------------ - --- | Runs the given configured program. -rawSystemProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -rawSystemProgram verbosity prog extraArgs - = rawSystemExit verbosity (programPath prog) (programArgs prog ++ extraArgs) - --- | Runs the given configured program and gets the output. -rawSystemProgramStdout :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -rawSystemProgramStdout verbosity prog extraArgs - = rawSystemStdout verbosity (programPath prog) (programArgs prog ++ extraArgs) - --- | Looks up the given program in the program configuration and runs it. -rawSystemProgramConf :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramConfiguration -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -rawSystemProgramConf verbosity prog programConf extraArgs = - case lookupProgram prog programConf of - Nothing -> die ("The program " ++ programName prog ++ " is required but it could not be found") - Just configuredProg -> rawSystemProgram verbosity configuredProg extraArgs - --- | Looks up the given program in the program configuration and runs it. -rawSystemProgramStdoutConf :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramConfiguration -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -rawSystemProgramStdoutConf verbosity prog programConf extraArgs = - case lookupProgram prog programConf of - Nothing -> die ("The program " ++ programName prog ++ " is required but it could not be found") - Just configuredProg -> rawSystemProgramStdout verbosity configuredProg extraArgs - --- ------------------------------------------------------------ --- * Known programs --- ------------------------------------------------------------ - --- | The default list of programs. --- These programs are typically used internally to Cabal. -builtinPrograms :: [Program] -builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , ghcPkgProgram - , hugsProgram - , ffihugsProgram - , nhcProgram - , hmakeProgram - , jhcProgram - -- preprocessors - , hscolourProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , ranlibProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] - -ghcProgram :: Program -ghcProgram = (simpleProgram "ghc") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -nhcProgram :: Program -nhcProgram = (simpleProgram "nhc98") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "nhc98 --version" gives a string like - -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)" - case words str of - (_:('v':ver):_) -> ver - _ -> "" - } - -hmakeProgram :: Program -hmakeProgram = (simpleProgram "hmake") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -jhcProgram :: Program -jhcProgram = (simpleProgram "jhc") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } - --- AArgh! Finding the version of hugs or ffihugs is almost impossible. -hugsProgram :: Program -hugsProgram = simpleProgram "hugs" - -ffihugsProgram :: Program -ffihugsProgram = simpleProgram "ffihugs" - -happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "alex --version" gives a string like - -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "" - } - - -ranlibProgram :: Program -ranlibProgram = simpleProgram "ranlib" - -arProgram :: Program -arProgram = simpleProgram "ar" - -stripProgram :: Program -stripProgram = simpleProgram "strip" - -hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = \verbosity path -> do - maybeVersion <- findProgramVersion "--version" (\str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "") verbosity path - - -- It turns out that it's important to know if hsc2hs is using gcc or ghc - -- as it's C compiler since this affects how we escape C options. - -- So here's a cunning hack, we make a temp .hsc file and call: - -- hsch2s tmp.hsc --cflag=--version - -- which passes --version through to ghc/gcc and we look at the result - -- to see if it was indeed ghc or not. - case maybeVersion of - Nothing -> return Nothing - Just version -> do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".hsc" $ \hsc hnd -> do - hClose hnd - (str, _) <- rawSystemStdout' verbosity path [hsc, "--cflag=--version"] - try $ removeFile (dropExtension hsc ++ "_hsc_make.c") - case words str of - (_:"Glorious":"Glasgow":"Haskell":_) - -> return $ Just version { versionTags = ["ghc"] } - _ -> return $ Just version - - } - -c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = findProgramOnPath "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "" - } - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" - -ldProgram :: Program -ldProgram = simpleProgram "ld" - -tarProgram :: Program -tarProgram = simpleProgram "tar" - -cppProgram :: Program -cppProgram = simpleProgram "cpp" - -pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs deleted file mode 100644 --- a/Distribution/Simple/Register.hs +++ /dev/null @@ -1,356 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Register --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Perform the \"@.\/setup register@\" action. --- Uses a drop-file for HC-PKG. See also "Distribution.InstalledPackageInfo". - -{- Copyright (c) 2003-2004, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Register ( - register, - unregister, - writeInstalledConfig, - removeInstalledConfig, - removeRegScripts, - ) where - -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), - InstallDirs(..), - absoluteInstallDirs) -import Distribution.Simple.BuildPaths (haddockName) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) -import Distribution.Simple.Program (ConfiguredProgram, programPath, - programArgs, rawSystemProgram, - lookupProgram, ghcPkgProgram) -import Distribution.Simple.Setup - ( RegisterFlags(..), CopyDest(..) - , fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.PackageDescription (PackageDescription(..), - BuildInfo(..), Library(..)) -import Distribution.Package - ( Package(..), packageName ) -import Distribution.InstalledPackageInfo - (InstalledPackageInfo, showInstalledPackageInfo, - emptyInstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, copyFileVerbose - , die, info, notice, setupMessage ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Text - ( display ) - -import System.FilePath ((), (<.>), isAbsolute) -import System.Directory (removeFile, getCurrentDirectory, - removeDirectoryRecursive, - setPermissions, getPermissions, - Permissions(executable)) -import System.IO.Error (try) - -import Control.Monad (when) -import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) -import Data.List (partition) - -regScriptLocation :: FilePath -regScriptLocation = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - -unregScriptLocation :: FilePath -unregScriptLocation = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" - --- ----------------------------------------------------------------------------- --- Registration - -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg_descr lbi regFlags - | isNothing (library pkg_descr) = do - setupMessage (fromFlag $ regVerbosity regFlags) "No package to register" (packageId pkg_descr) - return () - | otherwise = do - let distPref = fromFlag $ regDistPref regFlags - isWindows = case buildOS of Windows -> True; _ -> False - genScript = fromFlag (regGenScript regFlags) - genPkgConf = isJust (flagToMaybe (regGenPkgConf regFlags)) - genPkgConfigDefault = display (packageId pkg_descr) <.> "conf" - genPkgConfigFile = fromMaybe genPkgConfigDefault - (fromFlag (regGenPkgConf regFlags)) - verbosity = fromFlag (regVerbosity regFlags) - packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags) - inplace = fromFlag (regInPlace regFlags) - message | genPkgConf = "Writing package registration file: " - ++ genPkgConfigFile ++ " for" - | genScript = "Writing registration script: " - ++ regScriptLocation ++ " for" - | otherwise = "Registering" - setupMessage verbosity message (packageId pkg_descr) - - case compilerFlavor (compiler lbi) of - GHC -> do - config_flags <- case packageDB of - GlobalPackageDB -> return [] - UserPackageDB -> return ["--user"] - SpecificPackageDB db -> return ["--package-conf=" ++ db] - - let instConf | genPkgConf = genPkgConfigFile - | inplace = inplacePkgConfigFile distPref - | otherwise = installedPkgConfigFile distPref - - when (genPkgConf || not genScript) $ do - info verbosity ("create " ++ instConf) - writeInstalledConfig distPref pkg_descr lbi inplace (Just instConf) - - let register_flags = let conf = if genScript && not isWindows - then ["-"] - else [instConf] - in "update" : conf - - let allFlags = config_flags ++ register_flags - let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) - - case () of - _ | genPkgConf -> return () - | genScript -> - do cfg <- showInstalledConfig distPref pkg_descr lbi inplace - rawSystemPipe pkgTool regScriptLocation cfg allFlags - _ -> rawSystemProgram verbosity pkgTool allFlags - - Hugs -> do - when inplace $ die "--inplace is not supported with Hugs" - let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - createDirectoryIfMissingVerbose verbosity True (libdir installDirs) - copyFileVerbose verbosity (installedPkgConfigFile distPref) - (libdir installDirs "package.conf") - JHC -> notice verbosity "registering for JHC (nothing to do)" - NHC -> notice verbosity "registering nhc98 (nothing to do)" - _ -> die "only registering with GHC/Hugs/jhc/nhc98 is implemented" - --- ----------------------------------------------------------------------------- --- The installed package config - --- |Register doesn't drop the register info file, it must be done in a --- separate step. -writeInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo - -> Bool -> Maybe FilePath -> IO () -writeInstalledConfig distPref pkg_descr lbi inplace instConfOverride = do - pkg_config <- showInstalledConfig distPref pkg_descr lbi inplace - let instConfDefault | inplace = inplacePkgConfigFile distPref - | otherwise = installedPkgConfigFile distPref - instConf = fromMaybe instConfDefault instConfOverride - writeFile instConf (pkg_config ++ "\n") - --- |Create a string suitable for writing out to the package config file -showInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo -> Bool - -> IO String -showInstalledConfig distPref pkg_descr lbi inplace - = do cfg <- mkInstalledPackageInfo distPref pkg_descr lbi inplace - return (showInstalledPackageInfo cfg) - -removeInstalledConfig :: FilePath -> IO () -removeInstalledConfig distPref = do - try $ removeFile $ installedPkgConfigFile distPref - try $ removeFile $ inplacePkgConfigFile distPref - return () - -removeRegScripts :: IO () -removeRegScripts = do - try $ removeFile regScriptLocation - try $ removeFile unregScriptLocation - return () - -installedPkgConfigFile :: FilePath -> FilePath -installedPkgConfigFile distPref = distPref "installed-pkg-config" - -inplacePkgConfigFile :: FilePath -> FilePath -inplacePkgConfigFile distPref = distPref "inplace-pkg-config" - --- ----------------------------------------------------------------------------- --- Making the InstalledPackageInfo - -mkInstalledPackageInfo - :: FilePath - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> IO InstalledPackageInfo -mkInstalledPackageInfo distPref pkg_descr lbi inplace = do - pwd <- getCurrentDirectory - let - lib = fromJust (library pkg_descr) -- checked for Nothing earlier - bi = libBuildInfo lib - build_dir = pwd buildDir lbi - installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - inplaceDirs = (absoluteInstallDirs pkg_descr lbi NoCopyDest) { - datadir = pwd, - datasubdir = distPref, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - where inplaceDocdir = pwd distPref "doc" - inplaceHtmldir = inplaceDocdir "html" - packageName pkg_descr - (absinc,relinc) = partition isAbsolute (includeDirs bi) - installIncludeDir | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] - haddockInterfaceDir - | inplace = haddockdir inplaceDirs - | otherwise = haddockdir installDirs - haddockHtmlDir - | inplace = htmldir inplaceDirs - | otherwise = htmldir installDirs - libraryDir - | inplace = build_dir - | otherwise = libdir installDirs - hasModules = not $ null (exposedModules lib) - && null (otherModules bi) - hasLibrary = hasModules || not (null (cSources bi)) - in - return emptyInstalledPackageInfo{ - IPI.package = packageId pkg_descr, - IPI.license = license pkg_descr, - IPI.copyright = copyright pkg_descr, - IPI.maintainer = maintainer pkg_descr, - IPI.author = author pkg_descr, - IPI.stability = stability pkg_descr, - IPI.homepage = homepage pkg_descr, - IPI.pkgUrl = pkgUrl pkg_descr, - IPI.description = description pkg_descr, - IPI.category = category pkg_descr, - IPI.exposed = True, - IPI.exposedModules = exposedModules lib, - IPI.hiddenModules = otherModules bi, - IPI.importDirs = [ libraryDir | hasModules ], - IPI.libraryDirs = if hasLibrary - then libraryDir : extraLibDirs bi - else extraLibDirs bi, - IPI.hsLibraries = ["HS" ++ display (packageId pkg_descr) - | hasLibrary ], - IPI.extraLibraries = extraLibs bi, - IPI.includeDirs = absinc ++ if inplace - then map (pwd ) relinc - else installIncludeDir, - IPI.includes = includes bi, - IPI.depends = packageDeps lbi, - IPI.hugsOptions = concat [opts | (Hugs,opts) <- options bi], - IPI.ccOptions = ccOptions bi, - IPI.ldOptions = ldOptions bi, - IPI.frameworkDirs = [], - IPI.frameworks = frameworks bi, - IPI.haddockInterfaces = [haddockInterfaceDir haddockName pkg_descr], - IPI.haddockHTMLs = [haddockHtmlDir] - } - --- ----------------------------------------------------------------------------- --- Unregistration - -unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg_descr lbi regFlags = do - let genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (regVerbosity regFlags) - packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags) - installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - setupMessage verbosity "Unregistering" (packageId pkg_descr) - case compilerFlavor (compiler lbi) of - GHC -> do - config_flags <- case packageDB of - GlobalPackageDB -> return [] - UserPackageDB -> return ["--user"] - SpecificPackageDB db -> return ["--package-conf=" ++ db] - - let removeCmd = ["unregister", display (packageId pkg_descr)] - let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) - allArgs = removeCmd ++ config_flags - if genScript - then rawSystemEmit pkgTool unregScriptLocation allArgs - else rawSystemProgram verbosity pkgTool allArgs - Hugs -> do - try $ removeDirectoryRecursive (libdir installDirs) - return () - NHC -> do - try $ removeDirectoryRecursive (libdir installDirs) - return () - _ -> - die ("only unregistering with GHC and Hugs is implemented") - --- |Like rawSystemProgram, but emits to a script instead of exiting. --- FIX: chmod +x? -rawSystemEmit :: ConfiguredProgram -- ^Program to run - -> FilePath -- ^Script name - -> [String] -- ^Args - -> IO () -rawSystemEmit prog scriptName extraArgs - = case buildOS of - Windows -> - writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) - _ -> do writeFile scriptName ("#!/bin/sh\n\n" - ++ (path ++ concatMap (' ':) args) - ++ "\n") - p <- getPermissions scriptName - setPermissions scriptName p{executable=True} - where args = programArgs prog ++ extraArgs - path = programPath prog - --- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x -rawSystemPipe :: ConfiguredProgram - -> FilePath -- ^Script location - -> String -- ^where to pipe from - -> [String] -- ^Args - -> IO () -rawSystemPipe prog scriptName pipeFrom extraArgs - = case buildOS of - Windows -> - writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) - _ -> do writeFile scriptName ("#!/bin/sh\n\n" - ++ "echo '" ++ escapeForShell pipeFrom - ++ "' | " - ++ (path ++ concatMap (' ':) args) - ++ "\n") - p <- getPermissions scriptName - setPermissions scriptName p{executable=True} - where escapeForShell [] = [] - escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs - escapeForShell (c :cs) = c : escapeForShell cs - args = programArgs prog ++ extraArgs - path = programPath prog diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs deleted file mode 100644 --- a/Distribution/Simple/Setup.hs +++ /dev/null @@ -1,1434 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Data types and parser for the standard command-line --- setup. Will also return commands it doesn't know about. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - MakefileFlags(..), emptyMakefileFlags, defaultMakefileFlags, makefileCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - CopyDest(..), - configureArgs, configureOptions, - - defaultDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where - -import Distribution.Compiler () -import Distribution.ReadE -import Distribution.Text (display, Text(parse)) -import Distribution.Package ( Dependency(..) ) -import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) - , OptimisationLevel(..), flagToOptimisationLevel ) -import Distribution.Simple.Utils - ( wrapLine, lowercase ) -import Distribution.Simple.Program (Program(..), ProgramConfiguration, - knownPrograms) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), CopyDest(..), - PathTemplate, toPathTemplate, fromPathTemplate ) -import Data.List (sort) -import Data.Char (isSpace) -import Data.Monoid (Monoid(..)) -import Distribution.Verbosity - --- XXX Not sure where this should live -defaultDistPref :: FilePath -defaultDistPref = "dist" - --- ------------------------------------------------------------ --- * Flag type --- ------------------------------------------------------------ - --- | All flags are monoids, they come in two flavours: --- --- 1. list flags eg --- --- > --ghc-option=foo --ghc-option=bar --- --- gives us all the values ["foo", "bar"] --- --- 2. singular value flags, eg: --- --- > --enable-foo --disable-foo --- --- gives us Just False --- So this Flag type is for the latter singular kind of flag. --- Its monoid instance gives us the behaviour where it starts out as --- 'NoFlag' and later flags override earlier ones. --- -data Flag a = Flag a | NoFlag deriving (Show, Eq) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Monoid (Flag a) where - mempty = NoFlag - _ `mappend` f@(Flag _) = f - f `mappend` NoFlag = f - -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound - -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] - -toFlag :: a -> Flag a -toFlag = Flag - -fromFlag :: Flag a -> a -fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" - -fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def - -flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing - -flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- In fact since individual flags types are monoids and these are just sets of --- flags then they are also monoids pointwise. This turns out to be really --- useful. The mempty is the set of empty flags and mappend allows us to --- override specific flags. For example we can start with default flags and --- override with the ones we get from a file or the command line, or both. - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } - -globalCommand :: CommandUI GlobalFlags -globalCommand = makeCommand name shortDesc longDesc defaultGlobalFlags options - where - name = "" - shortDesc = "" - longDesc = Just $ \pname -> - "Typical steps for installing Cabal packages:\n" - ++ unlines [ " " ++ pname ++ " " ++ x - | x <- ["configure", "build", "install"]] - ++ "\nFor more information about a command, try '" - ++ pname ++ " COMMAND --help'." - ++ "\nThis Setup program uses the Haskell Cabal Infrastructure." - ++ "\nSee http://www.haskell.org/cabal/ for more information.\n" - options _ = - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - -emptyGlobalFlags :: GlobalFlags -emptyGlobalFlags = mempty - -instance Monoid GlobalFlags where - mempty = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty - } - mappend a b = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - --- | Flags to @configure@ command -data ConfigFlags = ConfigFlags { - --FIXME: the configPrograms is only here to pass info through to configure - -- because the type of configure is constrained by the UserHooks. - -- when we change UserHooks next we should pass the initial - -- ProgramConfiguration directly and not via ConfigFlags - configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run - - configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths - configProgramArgs :: [(String, [String])], -- ^user specifed programs args - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configProfExe :: Flag Bool, -- ^Enable profiling in the executables. - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configVerbose :: Verbosity, -- ^verbosity level (deprecated) - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDB :: Flag PackageDB, -- ^Which package DB to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configConstraints :: [Dependency], -- ^Additional constraints for - -- dependencies - configConfigurationsFlags :: FlagAssignment - } - deriving Show - -defaultConfigFlags :: ProgramConfiguration -> ConfigFlags -defaultConfigFlags progConf = emptyConfigFlags { - configPrograms = progConf, - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = Flag False, - configSharedLib = Flag False, - configProfExe = Flag False, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = Flag defaultDistPref, - configVerbose = normal, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this - configGHCiLib = Flag True, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = Flag True - } - -configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags -configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options - where - name = "configure" - shortDesc = "Prepare to build the package." - longDesc = Just (\_ -> programFlagsDescription progConf) - defaultFlags = defaultConfigFlags progConf - options showOrParseArgs = - configureOptions showOrParseArgs - ++ programConfigurationPaths progConf showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programConfigurationOptions progConf showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions showOrParseArgs = - [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) - ,optionDistPref configDistPref (\d flags -> flags { configDistPref = d }) - - ,option [] ["compiler"] "compiler" - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") - , (Flag NHC, ([] , ["nhc98"]), "compile with NHC") - , (Flag JHC, ([] , ["jhc"]), "compile with JHC") - , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")]) - - ,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") - - ,option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - ,option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - ,option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - ,option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - ,option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - ,option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - ,option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - ,option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - ,option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - ,option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - - ,option "b" ["scratchdir"] - "directory to receive the built package [dist/scratch]" - configScratchDir (\v flags -> flags { configScratchDir = v }) - (reqArgFlag "DIR") - - ,option "" ["program-prefix"] - "prefix to be applied to installed executables" - configProgPrefix - (\v flags -> flags { configProgPrefix = v }) - (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] - "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) - (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ("enable-optimization": case showOrParseArgs of - -- Allow British English spelling: - ShowArgs -> []; ParseArgs -> ["enable-optimisation"]) - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ("disable-optimization": case showOrParseArgs of - -- Allow British English spelling: - ShowArgs -> []; ParseArgs -> ["disable-optimisation"]) - "Build without optimization" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - "Use a specific package database (to satisfy dependencies and register in)" - configPackageDB (\v flags -> flags { configPackageDB = v }) - (reqArg' "PATH" (Flag . SpecificPackageDB) - (\f -> case f of - Flag (SpecificPackageDB db) -> [db] - _ -> [])) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg' "FLAGS" readFlagList showFlagList) - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) - (map (\x -> display x))) - ] - where - readFlagList :: String -> FlagAssignment - readFlagList = map tagWithValue . words - where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) - tagWithValue fname = (FlagName (lowercase fname), True) - - showFlagList :: FlagAssignment -> [String] - showFlagList fs = [ if not set then '-':fname else fname - | (FlagName fname, set) <- fs] - - installDirArg _sf _lf d get set = reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate.get.configInstallDirs) - (\v flags -> flags { configInstallDirs = - set (fmap toPathTemplate v) (configInstallDirs flags)}) - - reqPathTemplateArgFlag title _sf _lf d get set = reqArgFlag title _sf _lf d - (fmap fromPathTemplate.get) - (\v flags -> set (fmap toPathTemplate v) flags) - -emptyConfigFlags :: ConfigFlags -emptyConfigFlags = mempty - -instance Monoid ConfigFlags where - mempty = ConfigFlags { - configPrograms = error "FIXME: remove configPrograms", - configProgramPaths = mempty, - configProgramArgs = mempty, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configProfExe = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configVerbose = normal, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDB = mempty, - configGHCiLib = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configExtraLibDirs = mempty, - configConstraints = mempty, - configExtraIncludeDirs = mempty, - configConfigurationsFlags = mempty - } - mappend a b = ConfigFlags { - configPrograms = configPrograms a, - configProgramPaths = combine configProgramPaths, - configProgramArgs = combine configProgramArgs, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configSharedLib = combine configSharedLib, - configProfExe = combine configProfExe, - configConfigureArgs = combine configConfigureArgs, - configOptimization = combine configOptimization, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - configInstallDirs = combine configInstallDirs, - configScratchDir = combine configScratchDir, - configDistPref = combine configDistPref, - configVerbose = fromFlagOrDefault (configVerbose a) (configVerbosity b), - configVerbosity = combine configVerbosity, - configUserInstall = combine configUserInstall, - configPackageDB = combine configPackageDB, - configGHCiLib = combine configGHCiLib, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configExtraLibDirs = combine configExtraLibDirs, - configConstraints = combine configConstraints, - configExtraIncludeDirs = combine configExtraIncludeDirs, - configConfigurationsFlags = combine configConfigurationsFlags - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Copy flags --- ------------------------------------------------------------ - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: CopyDest, - copyDest' :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbose :: Verbosity, - copyVerbosity :: Flag Verbosity - } - deriving Show - -defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = NoCopyDest, - copyDest' = Flag NoCopyDest, - copyDistPref = Flag defaultDistPref, - copyVerbose = normal, - copyVerbosity = Flag normal - } - -copyCommand :: CommandUI CopyFlags -copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options - where - name = "copy" - shortDesc = "Copy the files into the install locations." - longDesc = Just $ \_ -> - "Does not call register, and allows a prefix at install time\n" - ++ "Without the --destdir flag, configure determines location.\n" - options _ = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - ,optionDistPref copyDistPref (\d flags -> flags { copyDistPref = d }) - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest' (\v flags -> flags { copyDest' = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["copy-prefix"] - "[DEPRECATED, directory to copy files to instead of prefix]" - copyDest' (\v flags -> flags { copyDest' = v }) - (reqArg' "DIR" (Flag . CopyPrefix) - (\f -> case f of Flag (CopyPrefix p) -> [p]; _ -> [])) - - ] - -emptyCopyFlags :: CopyFlags -emptyCopyFlags = mempty - -instance Monoid CopyFlags where - mempty = CopyFlags { - copyDest = NoCopyDest, - copyDest' = mempty, - copyDistPref = mempty, - copyVerbose = normal, - copyVerbosity = mempty - } - mappend a b = CopyFlags { - copyDest = fromFlagOrDefault (copyDest a) (copyDest' b), - copyDest' = combine copyDest', - copyDistPref = combine copyDistPref, - copyVerbose = fromFlagOrDefault (copyVerbose a) (copyVerbosity b), - copyVerbosity = combine copyVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDistPref :: Flag FilePath, - installVerbose :: Verbosity, - installVerbosity :: Flag Verbosity - } - deriving Show - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDistPref = Flag defaultDistPref, - installVerbose = normal, - installVerbosity = Flag normal - } - -installCommand :: CommandUI InstallFlags -installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options - where - name = "install" - shortDesc = "Copy the files into the install locations. Run register." - longDesc = Just $ \_ -> - "Unlike the copy command, install calls the register command.\n" - ++ "If you want to install into a location that is not what was\n" - ++ "specified in the configure step, use the copy command.\n" - options _ = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref installDistPref (\d flags -> flags { installDistPref = d }) - - ,option "" ["packageDB"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ] - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = mempty - -instance Monoid InstallFlags where - mempty = InstallFlags{ - installPackageDB = mempty, - installDistPref = mempty, - installVerbose = normal, - installVerbosity = mempty - } - mappend a b = InstallFlags{ - installPackageDB = combine installPackageDB, - installDistPref = combine installDistPref, - installVerbose = fromFlagOrDefault (installVerbose a) (installVerbosity b), - installVerbosity = combine installVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - --- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDistPref :: Flag FilePath, - sDistVerbose :: Verbosity, - sDistVerbosity :: Flag Verbosity - } - deriving Show - -defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDistPref = Flag defaultDistPref, - sDistVerbose = normal, - sDistVerbosity = Flag normal - } - -sdistCommand :: CommandUI SDistFlags -sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options - where - name = "sdist" - shortDesc = "Generate a source distribution file (.tar.gz)." - longDesc = Nothing - options _ = - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref sDistDistPref (\d flags -> flags { sDistDistPref = d }) - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - ] - -emptySDistFlags :: SDistFlags -emptySDistFlags = mempty - -instance Monoid SDistFlags where - mempty = SDistFlags { - sDistSnapshot = mempty, - sDistDistPref = mempty, - sDistVerbose = normal, - sDistVerbosity = mempty - } - mappend a b = SDistFlags { - sDistSnapshot = combine sDistSnapshot, - sDistDistPref = combine sDistDistPref, - sDistVerbose = fromFlagOrDefault (sDistVerbose a) (sDistVerbosity b), - sDistVerbosity = combine sDistVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Register flags --- ------------------------------------------------------------ - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regVerbose :: Verbosity, - regVerbosity :: Flag Verbosity - } - deriving Show - -defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = Flag defaultDistPref, - regVerbose = normal, - regVerbosity = Flag normal - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options - where - name = "register" - shortDesc = "Register this package with the compiler." - longDesc = Nothing - options _ = - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d }) - - ,option "" ["packageDB"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon registration, register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default)upon registration, register this package in the system-wide package database")]) - - ,option "" ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace (\v flags -> flags { regInPlace = v }) - trueArg - - ,option "" ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - - ,option "" ["gen-pkg-config"] - "instead of registering, generate a package registration file" - regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) - (optArg' "PKG" Flag flagToList) - ] - -unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options - where - name = "unregister" - shortDesc = "Unregister this package with the compiler." - longDesc = Nothing - options _ = - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d }) - - ,option "" ["user"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "unregister this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) unregister this package in the system-wide package database")]) - - ,option "" ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - ] - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = mempty - -instance Monoid RegisterFlags where - mempty = RegisterFlags { - regPackageDB = mempty, - regGenScript = mempty, - regGenPkgConf = mempty, - regInPlace = mempty, - regDistPref = mempty, - regVerbose = normal, - regVerbosity = mempty - } - mappend a b = RegisterFlags { - regPackageDB = combine regPackageDB, - regGenScript = combine regGenScript, - regGenPkgConf = combine regGenPkgConf, - regInPlace = combine regInPlace, - regDistPref = combine regDistPref, - regVerbose = fromFlagOrDefault (regVerbose a) (regVerbosity b), - regVerbosity = combine regVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * HsColour flags --- ------------------------------------------------------------ - -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbose :: Verbosity, - hscolourVerbosity :: Flag Verbosity - } - deriving Show - -emptyHscolourFlags :: HscolourFlags -emptyHscolourFlags = mempty - -defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourDistPref = Flag defaultDistPref, - hscolourVerbose = normal, - hscolourVerbosity = Flag normal - } - -instance Monoid HscolourFlags where - mempty = HscolourFlags { - hscolourCSS = mempty, - hscolourExecutables = mempty, - hscolourDistPref = mempty, - hscolourVerbose = normal, - hscolourVerbosity = mempty - } - mappend a b = HscolourFlags { - hscolourCSS = combine hscolourCSS, - hscolourExecutables = combine hscolourExecutables, - hscolourDistPref = combine hscolourDistPref, - hscolourVerbose = fromFlagOrDefault (hscolourVerbose a) (hscolourVerbosity b), - hscolourVerbosity = combine hscolourVerbosity - } - where combine field = field a `mappend` field b - -hscolourCommand :: CommandUI HscolourFlags -hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options - where - name = "hscolour" - shortDesc = "Generate HsColour colourised code, in HTML format." - longDesc = Just (\_ -> "Requires hscolour.\n") - options _ = - [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - --- ------------------------------------------------------------ --- * Haddock flags --- ------------------------------------------------------------ - -data HaddockFlags = HaddockFlags { - haddockHoogle :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockExecutables :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockHscolour :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockDistPref :: Flag FilePath, - haddockVerbose :: Verbosity, - haddockVerbosity :: Flag Verbosity - } - deriving Show - -defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockHoogle = Flag False, - haddockHtmlLocation = NoFlag, - haddockExecutables = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockHscolour = Flag False, - haddockHscolourCss = NoFlag, - haddockDistPref = Flag defaultDistPref, - haddockVerbose = normal, - haddockVerbosity = Flag normal - } - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options - where - name = "haddock" - shortDesc = "Generate Haddock HTML documentation." - longDesc = Just (\_ -> "Requires cpphs and haddock.\n") - options _ = - [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref haddockDistPref (\d flags -> flags { haddockDistPref = d }) - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = v }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockInternal (\v flags -> flags { haddockInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockCss (\v flags -> flags { haddockCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source"] - "Hyperlink the documentation to the source code (using HsColour)" - haddockHscolour (\v flags -> flags { haddockHscolour = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) - (reqArgFlag "PATH") - ] - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = mempty - -instance Monoid HaddockFlags where - mempty = HaddockFlags { - haddockHoogle = mempty, - haddockHtmlLocation = mempty, - haddockExecutables = mempty, - haddockInternal = mempty, - haddockCss = mempty, - haddockHscolour = mempty, - haddockHscolourCss = mempty, - haddockDistPref = mempty, - haddockVerbose = normal, - haddockVerbosity = mempty - } - mappend a b = HaddockFlags { - haddockHoogle = combine haddockHoogle, - haddockHtmlLocation = combine haddockHtmlLocation, - haddockExecutables = combine haddockExecutables, - haddockInternal = combine haddockInternal, - haddockCss = combine haddockCss, - haddockHscolour = combine haddockHscolour, - haddockHscolourCss = combine haddockHscolourCss, - haddockDistPref = combine haddockDistPref, - haddockVerbose = fromFlagOrDefault (haddockVerbose a) (haddockVerbosity b), - haddockVerbosity = combine haddockVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Clean flags --- ------------------------------------------------------------ - -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbose :: Verbosity, - cleanVerbosity :: Flag Verbosity - } - deriving Show - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = Flag defaultDistPref, - cleanVerbose = normal, - cleanVerbosity = Flag normal - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options - where - name = "clean" - shortDesc = "Clean up after a build." - longDesc = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n") - options _ = - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref cleanDistPref (\d flags -> flags { cleanDistPref = d }) - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - -emptyCleanFlags :: CleanFlags -emptyCleanFlags = mempty - -instance Monoid CleanFlags where - mempty = CleanFlags { - cleanSaveConf = mempty, - cleanDistPref = mempty, - cleanVerbose = normal, - cleanVerbosity = mempty - } - mappend a b = CleanFlags { - cleanSaveConf = combine cleanSaveConf, - cleanDistPref = combine cleanDistPref, - cleanVerbose = fromFlagOrDefault (cleanVerbose a) (cleanVerbosity b), - cleanVerbosity = combine cleanVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -data BuildFlags = BuildFlags { - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbose :: Verbosity, - buildVerbosity :: Flag Verbosity - } - deriving Show - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramArgs = [], - buildDistPref = Flag defaultDistPref, - buildVerbose = normal, - buildVerbosity = Flag normal - } - -buildCommand :: ProgramConfiguration -> CommandUI BuildFlags -buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options - where - name = "build" - shortDesc = "Make this package ready for installation." - longDesc = Nothing - options showOrParseArgs = - optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) - : optionDistPref buildDistPref (\d flags -> flags { buildDistPref = d }) - - : programConfigurationOptions progConf showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) - -emptyBuildFlags :: BuildFlags -emptyBuildFlags = mempty - -instance Monoid BuildFlags where - mempty = BuildFlags { - buildProgramArgs = mempty, - buildVerbose = normal, - buildVerbosity = Flag normal, - buildDistPref = mempty - } - mappend a b = BuildFlags { - buildProgramArgs = combine buildProgramArgs, - buildVerbose = fromFlagOrDefault (buildVerbose a) (buildVerbosity b), - buildVerbosity = combine buildVerbosity, - buildDistPref = combine buildDistPref - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Makefile flags --- ------------------------------------------------------------ - -data MakefileFlags = MakefileFlags { - makefileFile :: Flag FilePath, - makefileDistPref :: Flag FilePath, - makefileVerbose :: Verbosity, - makefileVerbosity :: Flag Verbosity - } - deriving Show - -defaultMakefileFlags :: MakefileFlags -defaultMakefileFlags = MakefileFlags { - makefileFile = NoFlag, - makefileDistPref = Flag defaultDistPref, - makefileVerbose = normal, - makefileVerbosity = Flag normal - } - -makefileCommand :: CommandUI MakefileFlags -makefileCommand = makeCommand name shortDesc longDesc defaultMakefileFlags options - where - name = "makefile" - shortDesc = "Generate a makefile (only for GHC libraries)." - longDesc = Nothing - options _ = - [optionVerbosity makefileVerbosity (\v flags -> flags { makefileVerbosity = v }) - ,optionDistPref makefileDistPref (\d flags -> flags { makefileDistPref = d }) - - ,option "f" ["file"] - "Filename to use (default: Makefile)." - makefileFile (\f flags -> flags { makefileFile = f }) - (reqArgFlag "PATH") - ] - -emptyMakefileFlags :: MakefileFlags -emptyMakefileFlags = mempty - -instance Monoid MakefileFlags where - mempty = MakefileFlags { - makefileFile = mempty, - makefileDistPref = mempty, - makefileVerbose = normal, - makefileVerbosity = mempty - } - mappend a b = MakefileFlags { - makefileFile = combine makefileFile, - makefileDistPref = combine makefileDistPref, - makefileVerbose = fromFlagOrDefault (makefileVerbose a) (makefileVerbosity b), - makefileVerbosity = combine makefileVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity - } - deriving Show - -defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = Flag defaultDistPref, - testVerbosity = Flag normal - } - -testCommand :: CommandUI TestFlags -testCommand = makeCommand name shortDesc longDesc defaultTestFlags options - where - name = "test" - shortDesc = "Run the test suite, if any (configure with UserHooks)." - longDesc = Nothing - options _ = - [optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - ,optionDistPref testDistPref (\d flags -> flags { testDistPref = d }) - ] - -emptyTestFlags :: TestFlags -emptyTestFlags = mempty - -instance Monoid TestFlags where - mempty = TestFlags { - testDistPref = mempty, - testVerbosity = mempty - } - mappend a b = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Shared options utils --- ------------------------------------------------------------ - -programFlagsDescription :: ProgramConfiguration -> String -programFlagsDescription progConf = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progConf ] - ++ "\n" - -programConfigurationPaths - :: ProgramConfiguration - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programConfigurationPaths progConf showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) - where - withProgramPath prog = - option "" ["with-" ++ prog] - ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) - -programConfigurationOptions - :: ProgramConfiguration - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programConfigurationOptions progConf showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG", programOption "PROG"] - ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) - ++ map (programOption . programName . fst) (knownPrograms progConf) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) - - programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) - - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt' = Command.boolOpt' flagToMaybe Flag - -trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) -> - (Flag Bool -> (b -> b)) -> OptDescr b -trueArg = noArg (Flag True) -falseArg = noArg (Flag False) - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> OptionField flags -optionDistPref get set = - option "" ["distpref"] - ( "Control which directory Cabal puts its generated files in " - ++ "(default " ++ defaultDistPref ++ ")") - get set - (reqArgFlag "DIR") - -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags -optionVerbosity get set = - option "v" ["verbose"] - "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - --- ------------------------------------------------------------ --- * Other Utils --- ------------------------------------------------------------ - --- | Arguments to pass to a @configure@ script, e.g. generated by --- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ configConfigureArgs flags - where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) - --- | Helper function to split a string into a list of arguments. --- It's supposed to handle quoted things sensibly, eg: --- --- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" --- > = ["--foo=C:\Program Files\Bar", "--baz"] --- -splitArgs :: String -> [String] -splitArgs = space [] - where - space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s - - string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ( c :s) = string (c:w) s - - nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s - - word [] s = s - word w s = reverse w : s - --- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = --- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] --- (flags, commands', unkFlags, ers) --- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] --- in [TestLabel "very basic option parsing" $ TestList [ --- "getOpt flags" ~: "failed" ~: --- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, --- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] --- ~=? flags, --- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', --- "getOpt unknown opts" ~: "failed" ~: --- ["--unknown1", "--unknown2"] ~=? unkFlags, --- "getOpt errors" ~: "failed" ~: [] ~=? ers], --- --- TestLabel "test location of various compilers" $ TestList --- ["configure parsing for prefix and compiler flag" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) --- | (name, comp) <- m], --- --- TestLabel "find the package tool" $ TestList --- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, --- "--with-compiler=/foo/comp", "configure"]) --- | (name, comp) <- m], --- --- TestLabel "simpler commands" $ TestList --- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) --- | (flag, flagCmd) <- [("build", BuildCmd), --- ("install", InstallCmd Nothing False), --- ("sdist", SDistCmd), --- ("register", RegisterCmd False)] --- ] --- ] - -{- Testing ideas: - * IO to look for hugs and hugs-pkg (which hugs, etc) - * quickCheck to test permutations of arguments - * what other options can we over-ride with a command-line flag? --} diff --git a/Distribution/Simple/SetupWrapper.hs b/Distribution/Simple/SetupWrapper.hs deleted file mode 100644 --- a/Distribution/Simple/SetupWrapper.hs +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.SetupWrapper --- Copyright : (c) The University of Glasgow 2006 --- --- Maintainer : http://hackage.haskell.org/trac/hackage --- Stability : alpha --- Portability : portable --- --- The user interface to building and installing Cabal packages. --- If the @Built-Type@ field is specified as something other than --- 'Custom', and the current version of Cabal is acceptable, this performs --- setup actions directly. Otherwise it builds the setup script and --- runs it with the given arguments. - -module Distribution.Simple.SetupWrapper (setupWrapper) where - -import qualified Distribution.Make as Make -import Distribution.Simple -import Distribution.Simple.Utils -import Distribution.Simple.Configure - ( configCompiler, getInstalledPackages, - configDependency ) -import Distribution.PackageDescription - ( PackageDescription(..), GenericPackageDescription(..), BuildType(..) - , readPackageDescription ) -import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Program ( ProgramConfiguration, - emptyProgramConfiguration, - rawSystemProgramConf, ghcProgram ) -import Distribution.Simple.GHC (ghcVerbosityOptions) -import Distribution.Text - ( display ) -import Distribution.GetOpt -import Distribution.ReadE -import System.Directory -import Distribution.Verbosity -import System.FilePath ((), (<.>)) -import Control.Monad ( when, unless ) -import Data.Maybe ( fromMaybe ) -import Data.Monoid ( Monoid(mempty) ) - - -- read the .cabal file - -- - attempt to find the version of Cabal required - - -- if the Cabal file specifies the build type (not Custom), - -- - behave like a boilerplate Setup.hs of that type - -- otherwise, - -- - if we find GHC, - -- - build the Setup script with the right version of Cabal - -- - invoke it with args - -- - if we find runhaskell (TODO) - -- - use runhaskell to invoke it - -- - -- Later: - -- - add support for multiple packages, by figuring out - -- dependencies here and building/installing the sub packages - -- in the right order. -setupWrapper :: - FilePath -- ^ "dist" prefix - -> [String] -- ^ Command-line arguments. - -> Maybe FilePath -- ^ Directory to run in. If 'Nothing', the current directory is used. - -> IO () -setupWrapper distPref args mdir = inDir mdir $ do - let (flag_fn, _, _, errs) = getOpt' Permute opts args - when (not (null errs)) $ die (unlines errs) - let Flags { withCompiler = hc, withHcPkg = hcPkg, withVerbosity = verbosity - } = foldr (.) id flag_fn defaultFlags - - pkg_descr_file <- defaultPackageDesc verbosity - ppkg_descr <- readPackageDescription verbosity pkg_descr_file - - let - setupDir = distPref "setup" - setupHs = setupDir "setup" <.> "hs" - setupProg = setupDir "setup" <.> exeExtension - trySetupScript f on_fail = do - b <- doesFileExist f - if not b then on_fail else do - hasSetup <- do b' <- doesFileExist setupProg - if not b' then return False else do - t1 <- getModificationTime f - t2 <- getModificationTime setupProg - return (t1 < t2) - unless hasSetup $ do - (comp, conf) <- configCompiler (Just GHC) hc hcPkg - emptyProgramConfiguration normal - let verRange = descCabalVersion (packageDescription ppkg_descr) - cabal_flag <- configCabalFlag verbosity verRange comp conf - createDirectoryIfMissingVerbose verbosity True setupDir - rawSystemProgramConf verbosity ghcProgram conf $ - cabal_flag - ++ ["--make", f, "-o", setupProg - ,"-odir", setupDir, "-hidir", setupDir] - ++ ghcVerbosityOptions verbosity - rawSystemExit verbosity setupProg args - - let buildType' = fromMaybe Custom (buildType (packageDescription ppkg_descr)) - case lookup buildType' buildTypes of - Just (mainAction, mainText) -> - if withinRange cabalVersion (descCabalVersion (packageDescription ppkg_descr)) - then mainAction args -- current version is OK, so no need - -- to compile a special Setup.hs. - else do createDirectoryIfMissingVerbose verbosity True setupDir - writeUTF8File setupHs mainText - trySetupScript setupHs $ error "panic! shouldn't happen" - Nothing -> - trySetupScript "Setup.hs" $ - trySetupScript "Setup.lhs" $ - die "no special Build-Type, but lacks Setup.hs or Setup.lhs" - -buildTypes :: [(BuildType, ([String] -> IO (), String))] -buildTypes = [ - (Simple, (defaultMainArgs, "import Distribution.Simple; main=defaultMain")), - (Configure, (defaultMainWithHooksArgs autoconfUserHooks, - "import Distribution.Simple; main=defaultMainWithHooks autoconfUserHooks")), - (Make, (Make.defaultMainArgs, "import Distribution.Make; main=defaultMain"))] - -data Flags - = Flags { - withCompiler :: Maybe FilePath, - withHcPkg :: Maybe FilePath, - withVerbosity :: Verbosity - } - -defaultFlags :: Flags -defaultFlags = Flags { - withCompiler = Nothing, - withHcPkg = Nothing, - withVerbosity = normal - } - -setWithCompiler :: Maybe FilePath -> Flags -> Flags -setWithCompiler f flags = flags{ withCompiler=f } - -setWithHcPkg :: Maybe FilePath -> Flags -> Flags -setWithHcPkg f flags = flags{ withHcPkg=f } - -setVerbosity :: Verbosity -> Flags -> Flags -setVerbosity v flags = flags{ withVerbosity=v } - -opts :: [OptDescr (Flags -> Flags)] -opts = [ - Option "w" ["with-setup-compiler"] (ReqArg (setWithCompiler.Just) "PATH") - "give the path to a particular compiler to use on setup", - Option "" ["with-setup-hc-pkg"] (ReqArg (setWithHcPkg.Just) "PATH") - "give the path to the package tool to use on setup", - Option "v" ["verbose"] (OptArg (maybe (setVerbosity verbose) - (setVerbosity . readEOrFail flagToVerbosity)) "n") - "Control verbosity (n is 0--3, default verbosity level is 1)" - ] - -configCabalFlag :: Verbosity -> VersionRange -> Compiler -> ProgramConfiguration -> IO [String] -configCabalFlag _ AnyVersion _ _ = return [] -configCabalFlag verbosity range comp conf = do - packageIndex <- fromMaybe mempty - `fmap` getInstalledPackages verbosity comp UserPackageDB conf - -- user packages are *allowed* here, no portability problem - cabal_pkgid <- configDependency verbosity packageIndex (Dependency "Cabal" range) - return ["-package", display cabal_pkgid] diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs deleted file mode 100644 --- a/Distribution/Simple/SrcDist.hs +++ /dev/null @@ -1,357 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.SrcDist --- Copyright : Simon Marlow 2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Implements the \"@.\/setup sdist@\" command, which creates a source --- distribution for this package. That is, packs up the source code --- into a tarball. - -{- Copyright (c) 2003-2004, Simon Marlow -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- NOTE: FIX: we don't have a great way of testing this module, since --- we can't easily look inside a tarball once its created. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, - - -- ** Snaphots - prepareSnapshotTree, - snapshotVersion, - dateToSnapshotNumber, - ) where - -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) ) -import Distribution.PackageDescription.Check -import Distribution.Package - ( PackageIdentifier(pkgVersion), Package(..) ) -import Distribution.Version - ( Version(versionBranch), VersionRange(AnyVersion) ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File - , copyFiles, copyFileVerbose, findFile, findFileWithExtension - , withTempDirectory, dotToSep, defaultPackageDesc - , die, warn, notice, setupMessage ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag) -import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths ( autogenModuleName ) -import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, - rawSystemProgram, tarProgram ) -import Distribution.Text - ( display ) - -import Control.Monad(when, unless) -import Data.Char (toLower) -import Data.List (partition, isPrefixOf) -import Data.Maybe (isNothing, catMaybes) -import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) -import System.Directory (doesFileExist, doesDirectoryExist) -import Distribution.Verbosity (Verbosity) -import System.FilePath - ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) - --- |Create a source distribution. -sdist :: PackageDescription -- ^information from the tarball - -> Maybe LocalBuildInfo -- ^Information from configure - -> SDistFlags -- ^verbosity & snapshot - -> (FilePath -> FilePath) -- ^build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () -sdist pkg mb_lbi flags mkTmpDir pps = do - let distPref = fromFlag $ sDistDistPref flags - targetPref = distPref - tmpDir = mkTmpDir distPref - - -- do some QA - printPackageProblems verbosity pkg - - exists <- doesDirectoryExist tmpDir - when exists $ - die $ "Source distribution already in place. please move or remove: " - ++ tmpDir - - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." - - withTempDirectory verbosity tmpDir $ do - - setupMessage verbosity "Building source dist for" (packageId pkg) - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - if snapshot - then getClockTime >>= toCalendarTime - >>= prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg mb_lbi distPref tmpDir pps - targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref - notice verbosity $ "Source tarball created: " ++ targzFile - - where - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> Maybe LocalBuildInfo - -> FilePath -- ^dist dir - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO FilePath -- ^the name of the dir created and populated - -prepareTree verbosity pkg_descr mb_lbi distPref tmpDir pps = do - let targetDir = tmpDir tarBallName pkg_descr - createDirectoryIfMissingVerbose verbosity True targetDir - -- maybe move the library files into place - withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> - prepareDir verbosity pkg_descr distPref targetDir pps modules libBi - -- move the executables into place - withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi - srcMainFile <- do - ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) - case ppFile of - Nothing -> findFile (hsSourceDirs exeBi) mainPath - Just pp -> return pp - copyFileTo verbosity targetDir srcMainFile - flip mapM_ (dataFiles pkg_descr) $ \ filename -> do - let file = dataDir pkg_descr filename - dir = takeDirectory file - createDirectoryIfMissingVerbose verbosity True (targetDir dir) - copyFileVerbose verbosity file (targetDir file) - - when (not (null (licenseFile pkg_descr))) $ - copyFileTo verbosity targetDir (licenseFile pkg_descr) - flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do - copyFileTo verbosity targetDir fpath - - -- copy the install-include files - withLib $ \ l -> do - let lbi = libBuildInfo l - relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - incs <- mapM (findInc relincdirs) (installIncludes lbi) - flip mapM_ incs $ \(_,fpath) -> - copyFileTo verbosity targetDir fpath - - -- if the package was configured then we can run platform independent - -- pre-processors and include those generated files - case mb_lbi of - Just lbi | not (null pps) - -> preprocessSources pkg_descr (lbi { buildDir = targetDir buildDir lbi }) - True verbosity pps - _ -> return () - - -- setup isn't listed in the description file. - hsExists <- doesFileExist "Setup.hs" - lhsExists <- doesFileExist "Setup.lhs" - if hsExists then copyFileTo verbosity targetDir "Setup.hs" - else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" - else writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] - -- the description file itself - descFile <- defaultPackageDesc verbosity - copyFileVerbose verbosity descFile (targetDir descFile) - return targetDir - - where - findInc [] f = die ("can't find include file " ++ f) - findInc (d:ds) f = do - let path = (d f) - b <- doesFileExist path - if b then return (f,path) else findInc ds f - - -- We have to deal with all libs and executables, so we have local - -- versions of these functions that ignore the 'buildable' attribute: - withLib action = maybe (return ()) action (library pkg_descr) - withExe action = mapM_ action (executables pkg_descr) - --- | Prepare a directory tree of source files for a snapshot version with the --- given date. --- -prepareSnapshotTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> Maybe LocalBuildInfo - -> FilePath -- ^dist dir - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> CalendarTime -- ^snapshot date - -> IO FilePath -- ^the resulting temp dir -prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps date = do - let pkgid = packageId pkg - pkgver' = snapshotVersion date (pkgVersion pkgid) - pkg' = pkg { package = pkgid { pkgVersion = pkgver' } } - targetDir <- prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - overwriteSnapshotPackageDesc pkgver' targetDir - return targetDir - - where - overwriteSnapshotPackageDesc version targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion version) . lines - =<< readUTF8File descFile - - replaceVersion :: Version -> String -> String - replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ display version - | otherwise = line - --- | Modifies a 'PackageDescription' by appending a snapshot number --- corresponding to the given date. --- -snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription -snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg - --- | Modifies a 'Version' by appending a snapshot number corresponding --- to the given date. --- -snapshotVersion :: CalendarTime -> Version -> Version -snapshotVersion date version = version { - versionBranch = versionBranch version - ++ [dateToSnapshotNumber date] - } - --- | Given a date produce a corresponding integer representation. --- For example given a date @18/03/2008@ produce the number @20080318@. --- -dateToSnapshotNumber :: CalendarTime -> Int -dateToSnapshotNumber date = year * 10000 - + month * 100 - + day - where - year = ctYear date - month = fromEnum (ctMonth date) + 1 - day = ctDay date - --- |Create an archive from a tree of source files, and clean up the tree. -createArchive :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from cabal file - -> Maybe LocalBuildInfo -- ^info from configure - -> FilePath -- ^source tree to archive - -> FilePath -- ^name of archive to create - -> IO FilePath - -createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do - let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" - - (tarProg, _) <- requireProgram verbosity tarProgram AnyVersion - (maybe defaultProgramConfiguration withPrograms mb_lbi) - - -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?) - -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly, - -- which is problematic in a Windows setting.] - rawSystemProgram verbosity tarProg - ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr] - return tarBallFilePath - --- |Move the sources into place based on buildInfo -prepareDir :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^dist dir - -> FilePath -- ^TargetPrefix - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> [String] -- ^Exposed modules - -> BuildInfo - -> IO () -prepareDir verbosity pkg distPref inPref pps modules bi - = do let searchDirs = hsSourceDirs bi ++ [autogenModulesDir] - autogenModulesDir = distPref "build" "autogen" - autogenFile = autogenModulesDir autogenModuleName pkg <.> "hs" - -- the Paths_$pkgname module might be in the modules list. If it - -- turns out that resolves to the actual autogen file then we filter - -- it out because we do not want to put it into the tarball. - sources <- filter (/=autogenFile) `fmap` sequence - [ let file = dotToSep module_ - in findFileWithExtension suffixes searchDirs file - >>= maybe (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequence - [ let file = dotToSep module_ - in findFileWithExtension ["hs-boot"] (hsSourceDirs bi) file - | module_ <- modules ++ otherModules bi ] - - let allSources = sources ++ catMaybes bootFiles ++ cSources bi - copyFiles verbosity inPref (zip (repeat []) allSources) - - where suffixes = ppSuffixes pps ++ ["hs", "lhs"] - notFound m = die $ "Error: Could not find module: " ++ m - ++ " with any suffix: " ++ show suffixes - -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () -copyFileTo verbosity dir file = do - let targetFile = dir file - createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) - copyFileVerbose verbosity file targetFile - -printPackageProblems :: Verbosity -> PackageDescription -> IO () -printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles pkg_descr "." - let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError _ = True - (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) - unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map explanation errors) - unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map explanation warnings) - unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." - ------------------------------------------------------------- - --- | The name of the tarball without extension --- -tarBallName :: PackageDescription -> String -tarBallName = display . packageId diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs deleted file mode 100644 --- a/Distribution/Simple/UserHooks.hs +++ /dev/null @@ -1,213 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UserHooks --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Simple build system; basically the interface for --- Distribution.Simple.\* modules. When given the parsed command-line --- args and package information, is able to perform basic commands --- like configure, build, install, register, etc. --- --- 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. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.UserHooks ( - UserHooks(..), Args, - emptyUserHooks, - ) where - -import Distribution.PackageDescription - (PackageDescription, GenericPackageDescription, - HookedBuildInfo, emptyHookedBuildInfo) -import Distribution.Simple.Program (Program) -import Distribution.Simple.Command (noExtraFlags) -import Distribution.Simple.PreProcess (PPSuffixHandler) -import Distribution.Simple.Setup - (ConfigFlags, BuildFlags, MakefileFlags, CleanFlags, CopyFlags, - InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, - HaddockFlags) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) - -type Args = [String] - --- | Hooks allow authors to add specific functionality before and after a --- command is run, and also to specify additional preprocessors. --- --- * WARNING: The hooks interface is under rather constant flux as we try to --- understand users needs. Setup files that depend on this interface may --- break in future releases. -data UserHooks = UserHooks { - - -- | Used for @.\/setup test@ - runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), - -- | Read the description file - readDesc :: IO (Maybe PackageDescription), - -- | 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 :: ( Either GenericPackageDescription PackageDescription - , HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before build command. Second arg indicates verbosity level. - preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to gbet different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before makefile command. Second arg indicates verbosity level. - preMakefile :: Args -> MakefileFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during makefile. - makefileHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> MakefileFlags -> IO (), - -- |Hook to run after makefile command. Second arg indicates verbosity level. - postMakefile :: Args -> MakefileFlags -> 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 -> Maybe LocalBuildInfo -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before sdist command. Second arg indicates verbosity level. - preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during sdist. - sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), - -- |Hook to run after sdist command. Second arg indicates verbosity level. - postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO () - } - --- |Empty 'UserHooks' which do nothing. -emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - runTests = ru, - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn, - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn, - buildHook = ru, - postBuild = ru, - preMakefile = rn, - makefileHook = ru, - postMakefile = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn, - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preSDist = rn, - sDistHook = ru, - postSDist = ru, - preReg = rn, - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preHaddock = rn, - haddockHook = ru, - postHaddock = ru - } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - ru _ _ _ _ = return () diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs deleted file mode 100644 --- a/Distribution/Simple/Utils.hs +++ /dev/null @@ -1,788 +0,0 @@ -{-# OPTIONS -cpp -fffi #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_GHC -cpp -fffi #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Explanation: Misc. Utilities, especially file-related utilities. --- Stuff used by multiple modules that doesn't fit elsewhere. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Utils ( - cabalVersion, - cabalBootstrapping, - - -- * logging and errors - die, - dieWithLocation, - warn, notice, setupMessage, info, debug, - chattyTry, - breaks, - - -- * running programs - rawSystemExit, - rawSystemStdout, - rawSystemStdout', - maybeExit, - xargs, - inDir, - - -- * copying files - smartCopySources, - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyDirectoryRecursiveVerbose, - copyFiles, - - -- * file names - currentDir, - dotToSep, - - -- * finding files - findFile, - findFileWithExtension, - findFileWithExtension', - - -- * temp files and dirs - withTempFile, - withTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - defaultHookedPackageDesc, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - - -- * Unicode - fromUTF8, - toUTF8, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - - -- * generic utils - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - wrapText, - wrapLine, - ) where - -import Control.Monad - ( when, unless, filterM ) -import Data.List - ( nub, unfoldr, isPrefixOf, tails, intersperse ) -import Data.Char as Char - ( toLower, chr, ord ) -import Data.Bits - ( Bits((.|.), (.&.), shiftL, shiftR) ) - -import System.Directory - ( getDirectoryContents, getCurrentDirectory, setCurrentDirectory, doesDirectoryExist - , doesFileExist, removeFile ) -import System.Environment - ( getProgName ) -import System.Cmd - ( rawSystem ) -import System.Exit - ( exitWith, ExitCode(..) ) -import System.FilePath - ( takeDirectory, splitFileName, splitExtension, normalise - , (), (<.>), pathSeparator ) -import System.Directory - ( copyFile, createDirectoryIfMissing, renameFile, removeDirectoryRecursive ) -import System.IO - ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode - , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) -import System.IO.Error as IO.Error - ( try ) -import qualified Control.Exception as Exception - ( bracket, bracket_, catch, handle, finally, throwIO ) - -import Distribution.Text - ( display ) -import Distribution.Package - ( PackageIdentifier ) -import Distribution.Version - (Version(..)) - -#ifdef __GLASGOW_HASKELL__ -import Control.Concurrent (forkIO) -import Control.Exception (evaluate) -import System.Process (runInteractiveProcess, waitForProcess) -#else -import System.Cmd (system) -import System.Directory (getTemporaryDirectory) -#endif - -import Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) -import Distribution.Verbosity - --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#ifdef CABAL_VERSION -cabalVersion = Version [CABAL_VERSION] [] -#else -cabalVersion = error "Cabal was not bootstrapped correctly" -#endif - -cabalBootstrapping :: Bool -#ifdef CABAL_VERSION -cabalBootstrapping = False -#else -cabalBootstrapping = True -#endif - --- ------------------------------------------------------------------------------- Utils for setup - -dieWithLocation :: FilePath -> Maybe Int -> String -> IO a -dieWithLocation filename lineno msg = - die $ normalise filename - ++ maybe "" (\n -> ":" ++ show n) lineno - ++ ": " ++ msg - -die :: String -> IO a -die msg = do - hFlush stdout - pname <- getProgName - hPutStr stderr (wrapText (pname ++ ": " ++ msg)) - exitWith (ExitFailure 1) - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = - when (verbosity >= normal) $ do - hFlush stdout - hPutStr stderr (wrapText ("Warning: " ++ msg)) - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- enough information to know that things are working but not floods of detail. --- -notice :: Verbosity -> String -> IO () -notice verbosity msg = - when (verbosity >= normal) $ - putStr (wrapText msg) - -setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () -setupMessage verbosity msg pkgid = - notice verbosity (msg ++ ' ': display pkgid ++ "...") - --- | More detail on the operation of some action. --- --- We display these messages when the verbosity level is 'verbose' --- -info :: Verbosity -> String -> IO () -info verbosity msg = - when (verbosity >= verbose) $ - putStr (wrapText msg) - --- | Detailed internal debugging information --- --- We display these messages when the verbosity level is 'deafening' --- -debug :: Verbosity -> String -> IO () -debug verbosity msg = - when (verbosity >= deafening) $ - putStr (wrapText msg) - --- | 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 = - Exception.catch action $ \exception -> - putStrLn $ "Error while " ++ desc ++ ": " ++ show exception - --- ----------------------------------------------------------------------------- --- Helper functions - -breaks :: (a -> Bool) -> [a] -> [[a]] -breaks _ [] = [] -breaks f xs = case span f xs of - (_, xs') -> - case break f xs' of - (v, xs'') -> - v : breaks f xs'' - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . concatMap (map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - --- ----------------------------------------------------------------------------- --- rawSystem variants -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - res <- cmd - unless (res == ExitSuccess) $ exitWith res - -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args - | verbosity >= deafening = print (path, args) - | verbosity >= verbose = putStrLn $ unwords (path : args) - | otherwise = return () - --- Exit with the same exitcode if the subcommand fails -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - --- | Run a command and return its output. --- --- The output is assumed to be encoded as UTF8. --- -rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String -rawSystemStdout verbosity path args = do - (output, exitCode) <- rawSystemStdout' verbosity path args - unless (exitCode == ExitSuccess) $ exitWith exitCode - return output - -rawSystemStdout' :: Verbosity -> FilePath -> [String] -> IO (String, ExitCode) -rawSystemStdout' verbosity path args = do - printRawCommandAndArgs verbosity path args - -#ifdef __GLASGOW_HASKELL__ - Exception.bracket - (runInteractiveProcess path args Nothing Nothing) - (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) - $ \(_,outh,errh,pid) -> do - - -- We want to process the output as text. - hSetBinaryMode outh False - - -- fork off a thread to pull on (and discard) the stderr - -- so if the process writes to stderr we do not block. - -- NB. do the hGetContents synchronously, otherwise the outer - -- bracket can exit before this thread has run, and hGetContents - -- will fail. - err <- hGetContents errh - forkIO $ do evaluate (length err); return () - - -- wait for all the output - output <- hGetContents outh - evaluate (length output) - - -- wait for the program to terminate - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - - return (output, exitcode) -#else - tmpDir <- getTemporaryDirectory - withTempFile tmpDir ".cmd.stdout" $ \tmpName tmpHandle -> do - hClose tmpHandle - let quote name = "'" ++ name ++ "'" - exitcode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - withFileContents tmpName $ \output -> - length output `seq` return (output, exitcode) -#endif - --- | Like the unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- | Executes the action in the specified directory. -inDir :: Maybe FilePath -> IO () -> IO () -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die $ fileName ++ " doesn't exist") return - -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - -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 - -dotToSep :: String -> String -dotToSep = map dts - where - dts '.' = pathSeparator - dts c = c - --- |Copy the source files into the right directory. Looks in the --- build prefix for files that look like the input modules, based on --- the input search suffixes. It copies the files into the target --- directory. - -smartCopySources :: Verbosity -- ^verbosity - -> [FilePath] -- ^build prefix (location of objects) - -> FilePath -- ^Target directory - -> [String] -- ^Modules - -> [String] -- ^search suffixes - -> IO () -smartCopySources verbosity srcDirs targetDir sources searchSuffixes - = mapM moduleToFPErr sources >>= copyFiles verbosity targetDir - - where moduleToFPErr m - = findFileWithExtension' searchSuffixes srcDirs (dotToSep m) - >>= maybe notFound return - where notFound = die $ "Error: Could not find module: " ++ m - ++ " with any suffix: " ++ show searchSuffixes - -createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO () -createDirectoryIfMissingVerbose verbosity parentsToo dir = do - let msgParents = if parentsToo then " (and its parents)" else "" - info verbosity ("Creating " ++ dir ++ msgParents) - createDirectoryIfMissing parentsToo dir - -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in copyFileVerbose verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- adaptation of removeDirectoryRecursive -copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursiveVerbose verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - let aux src dest = - let cp :: FilePath -> IO () - cp f = let srcFile = src f - destFile = dest f - in do success <- try (copyFileVerbose verbosity srcFile destFile) - case success of - Left e -> do isDir <- doesDirectoryExist srcFile - -- If f is not a directory, re-throw the error - unless isDir $ ioError e - aux srcFile destFile - Right _ -> return () - in do createDirectoryIfMissingVerbose verbosity False dest - getDirectoryContentsWithoutSpecial src >>= mapM_ cp - in aux srcDir destDir - - where getDirectoryContentsWithoutSpecial = - fmap (filter (not . flip elem [".", ".."])) - . getDirectoryContents - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> hClose handle >> removeFile name) - (uncurry action) - --- | Use a temporary directory. --- --- Use this exact given dir which must not already exist. --- -withTempDirectory :: Verbosity -> FilePath -> IO a -> IO a -withTempDirectory verbosity tmpDir = - Exception.bracket_ - (createDirectoryIfMissingVerbose verbosity True tmpDir) - (removeDirectoryRecursive tmpDir) - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - Exception.bracket (openFile name ReadMode) hClose - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written sucessfully or an IO exception is raised and --- the original file is left unchanged. --- --- * Warning: On Windows this operation is very nearly but not quite atomic. --- See below. --- --- On Posix it works by writing a temporary file and atomically renaming over --- the top any pre-existing target file with the temporary one. --- --- On Windows it is not possible to rename over an existing file so the target --- file has to be deleted before the temporary file is renamed to the target. --- Therefore there is a race condition between the existing file being removed --- and the temporary file being renamed. Another thread could write to the --- target or change the permission on the target directory between the deleting --- and renaming steps. An exception would be raised but the target file would --- either no longer exist or have the content as written by the other thread. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do - (tmpFile, tmpHandle) <- openBinaryTempFile targetDir template - Exception.handle (\err -> do hClose tmpHandle - removeFile tmpFile - Exception.throwIO err) $ do - hPutStr tmpHandle content - hClose tmpHandle -#if mingw32_HOST_OS || mingw32_TARGET_OS - renameFile tmpFile targetFile - -- If the targetFile exists then renameFile will fail - `Exception.catch` \err -> do - exists <- doesFileExist targetFile - if exists - then do removeFile targetFile - -- Big fat hairy race condition - renameFile tmpFile targetFile - -- If the removeFile succeeds and the renameFile fails - -- then we've lost the atomic property. - else Exception.throwIO err -#else - renameFile tmpFile targetFile -#endif - where - template = targetName <.> "tmp" - targetDir | null targetDir_ = currentDir - | otherwise = targetDir_ - --TODO: remove this when takeDirectory/splitFileName is fixed - -- to always return a valid dir - (targetDir_,targetName) = splitFileName targetFile - - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- |Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc _verbosity = findPackageDesc currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO FilePath -- ^.cabal -findPackageDesc dir - = do files <- getDirectoryContents 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 - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> noDesc - [cabalFile] -> return cabalFile - multiple -> multiDesc multiple - - where - noDesc :: IO a - noDesc = die $ "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> IO a - multiDesc l = die $ "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ show l - --- |Optional auxiliary package information file (/pkgname/@.buildinfo@) -defaultHookedPackageDesc :: IO (Maybe FilePath) -defaultHookedPackageDesc = findHookedPackageDesc currentDir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String -buildInfoExt = ".buildinfo" - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- This is a modification of the UTF8 code from gtk2hs and the --- utf8-string package. - -fromUTF8 :: String -> String -fromUTF8 [] = [] -fromUTF8 (c:cs) - | c <= '\x7F' = c : fromUTF8 cs - | c <= '\xBF' = replacementChar : fromUTF8 cs - | c <= '\xDF' = twoBytes c cs - | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) - | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) - | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) - | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) - | otherwise = replacementChar : fromUTF8 cs - where - twoBytes c0 (c1:cs') - | ord c1 .&. 0xC0 == 0x80 - = let d = ((ord c0 .&. 0x1F) `shiftL` 6) - .|. (ord c1 .&. 0x3F) - in if d >= 0x80 - then chr d : fromUTF8 cs' - else replacementChar : fromUTF8 cs' - twoBytes _ cs' = replacementChar : fromUTF8 cs' - - moreBytes :: Int -> Int -> [Char] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc && acc <= 0x10FFFF - && (acc < 0xD800 || 0xDFFF < acc) - && (acc < 0xFFFE || 0xFFFF < acc) - = chr acc : fromUTF8 cs' - - | otherwise - = replacementChar : fromUTF8 cs' - - moreBytes byteCount overlong (cn:cs') acc - | ord cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. ord cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : fromUTF8 cs' - - replacementChar = '\xfffd' - -toUTF8 :: String -> String -toUTF8 [] = [] -toUTF8 (c:cs) - | c <= '\x07F' = c - : toUTF8 cs - | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | otherwise = chr (0xf0 .|. (w `shiftR` 18)) - : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - where w = ord c - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = fmap fromUTF8 . hGetContents =<< openBinaryFile f ReadMode - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - Exception.bracket (openBinaryFile name ReadMode) hClose - (\hnd -> hGetContents hnd >>= action . fromUTF8) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . toUTF8 - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - -comparing :: Ord a => (b -> a) -> b -> b -> Ordering -comparing p x y = p x `compare` p y - -isInfixOf :: String -> String -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) - -intercalate :: [a] -> [[a]] -> [a] -intercalate sep = concat . intersperse sep - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/Distribution/System.hs b/Distribution/System.hs deleted file mode 100644 --- a/Distribution/System.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - ) where - -import qualified System.Info (os, arch) -import qualified Data.Char as Char (toLower, isAlphaNum) - -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp - --- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --- --- The reason we have multiple ways to do the classification is because there --- are two situations where we need to do it. --- --- For parsing os and arch names in .cabal files we really want everyone to be --- referring to the same or or arch by the same name. Variety is not a virtue --- in this case. We don't mind about case though. --- --- For the System.Info.os\/arch different Haskell implementations use different --- names for the same or\/arch. Also they tend to distinguish versions of an --- os\/arch which we just don't care about. --- --- The 'Compat' classification allows us to recognise aliases that are already --- in common use but it allows us to distinguish them from the canonical name --- which enables us to warn about such deprecated aliases. --- -data ClassificationStrictness = Permissive | Compat | Strict - --- ------------------------------------------------------------ --- * Operating System --- ------------------------------------------------------------ - -data OS = Linux | Windows | OSX - | FreeBSD | OpenBSD | NetBSD - | Solaris | AIX | HPUX | IRIX - | OtherOS String - deriving (Eq, Ord, Show, Read) - -knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD - ,Solaris, AIX, HPUX, IRIX] - -osAliases :: ClassificationStrictness -> OS -> [String] -osAliases Permissive Windows = ["mingw32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Permissive Solaris = ["solaris2"] -osAliases _ _ = [] - -instance Text OS where - disp (OtherOS name) = Disp.text name - disp other = Disp.text (lowercase (show other)) - - parse = fmap (classifyOS Compat) ident - -classifyOS :: ClassificationStrictness -> String -> OS -classifyOS strictness s = - case lookup (lowercase s) osMap of - Just os -> os - Nothing -> OtherOS s - where - osMap = [ (name, os) - | os <- knownOSs - , name <- display os : osAliases strictness os ] - -buildOS :: OS -buildOS = classifyOS Permissive System.Info.os - --- ------------------------------------------------------------ --- * Machine Architecture --- ------------------------------------------------------------ - -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | Mips | SH - | IA64 | S390 - | Alpha | Hppa | Rs6000 - | M68k | Vax - | OtherArch String - deriving (Eq, Ord, Show, Read) - -knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, Mips, SH - ,IA64, S390 - ,Alpha, Hppa, Rs6000 - ,M68k, Vax] - -archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ _ = [] - -instance Text Arch where - disp (OtherArch name) = Disp.text name - disp other = Disp.text (lowercase (show other)) - - parse = fmap (classifyArch Strict) ident - -classifyArch :: ClassificationStrictness -> String -> Arch -classifyArch strictness s = - case lookup (lowercase s) archMap of - Just arch -> arch - Nothing -> OtherArch s - where - archMap = [ (name, arch) - | arch <- knownArches - , name <- display arch : archAliases strictness arch ] - -buildArch :: Arch -buildArch = classifyArch Permissive System.Info.arch - -ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - --TODO: probably should disallow starting with a number - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/Distribution/Text.hs b/Distribution/Text.hs deleted file mode 100644 --- a/Distribution/Text.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Distribution.Text ( - Text(..), - display, - simpleParse, - ) where - -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp - -import Data.Version (Version(Version)) -import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) - -class Text a where - disp :: a -> Disp.Doc - parse :: Parse.ReadP r a - -display :: Text a => a -> String -display = Disp.render . disp - -simpleParse :: Text a => String -> Maybe a -simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str - , all Char.isSpace s ] of - [] -> Nothing - (p:_) -> Just p - --- ----------------------------------------------------------------------------- --- Instances for types from the base package - -instance Text Bool where - disp = Disp.text . show - parse = Parse.choice [ (Parse.string "True" Parse.+++ - Parse.string "true") >> return True - , (Parse.string "False" Parse.+++ - Parse.string "false") >> return False ] - -instance Text Version where - disp (Version branch _tags) -- Do not display the tags - = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) - - parse = do - branch <- Parse.sepBy1 digits (Parse.char '.') - tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) - return (Version branch tags) - where - digits = do - first <- Parse.satisfy Char.isDigit - if first == '0' - then return 0 - else do rest <- Parse.munch Char.isDigit - return (read (first : rest)) diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs deleted file mode 100644 --- a/Distribution/Verbosity.hs +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Verbosity --- Copyright : Ian Lynagh 2007 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Verbosity for Cabal functions - -{- Copyright (c) 2007, Ian Lynagh -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC - ) where - -import Data.List (elemIndex) -import Distribution.ReadE - -data Verbosity = Silent | Normal | Verbose | Deafening - deriving (Show, Eq, Ord, Enum, Bounded) - --- We shouldn't print /anything/ unless an error occurs in silent mode -silent :: Verbosity -silent = Silent - --- Print stuff we want to see by default -normal :: Verbosity -normal = Normal - --- Be more verbose about what's going on -verbose :: Verbosity -verbose = Verbose - --- Not only are we verbose ourselves (perhaps even noisier than when --- being "verbose"), but we tell everything we run to be verbose too -deafening :: Verbosity -deafening = Deafening - -moreVerbose :: Verbosity -> Verbosity -moreVerbose Silent = Silent --silent should stay silent -moreVerbose Normal = Verbose -moreVerbose Verbose = Deafening -moreVerbose Deafening = Deafening - -lessVerbose :: Verbosity -> Verbosity -lessVerbose Deafening = Deafening -lessVerbose Verbose = Normal -lessVerbose Normal = Silent -lessVerbose Silent = Silent - -intToVerbosity :: Int -> Maybe Verbosity -intToVerbosity 0 = Just Silent -intToVerbosity 1 = Just Normal -intToVerbosity 2 = Just Verbose -intToVerbosity 3 = Just Deafening -intToVerbosity _ = Nothing - -flagToVerbosity :: ReadE Verbosity -flagToVerbosity = ReadE $ \s -> - case reads s of - [(i, "")] -> - case intToVerbosity i of - Just v -> Right v - Nothing -> Left ("Bad verbosity: " ++ show i ++ - ". Valid values are 0..3") - _ -> Left ("Can't parse verbosity " ++ s) - -showForCabal, showForGHC :: Verbosity -> String - -showForCabal v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex diff --git a/Distribution/Version.hs b/Distribution/Version.hs deleted file mode 100644 --- a/Distribution/Version.hs +++ /dev/null @@ -1,171 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Versions for packages, based on the 'Version' datatype. - -{- Copyright (c) 2003-2004, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Version ( - -- * Package versions - Version(..), - - -- * Version ranges - VersionRange(..), notThisVersion, - orLaterVersion, orEarlierVersion, - betweenVersionsInclusive, - withinRange, - isAnyVersion, - - -- * Deprecated compat stuff - showVersion, - parseVersion, - ) where - -import Data.Version ( Version(..) ) - -import Distribution.Text ( Text(..), display ) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((+++)) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>)) - --- ----------------------------------------------------------------------------- --- Version ranges - --- Todo: maybe move this to Distribution.Package.Version? --- (package-specific versioning scheme). - -data VersionRange - = AnyVersion - | ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | EarlierVersion Version -- < version - -- ToDo: are these too general? - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - deriving (Show,Read,Eq) - -isAnyVersion :: VersionRange -> Bool -isAnyVersion AnyVersion = True -isAnyVersion _ = False - -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - -orLaterVersion :: Version -> VersionRange -orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) - -orEarlierVersion :: Version -> VersionRange -orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) - - -betweenVersionsInclusive :: Version -> Version -> VersionRange -betweenVersionsInclusive v1 v2 = - IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) - -laterVersion :: Version -> Version -> Bool -v1 `laterVersion` v2 = versionBranch v1 > versionBranch v2 - -earlierVersion :: Version -> Version -> Bool -v1 `earlierVersion` v2 = versionBranch v1 < versionBranch v2 - --- |Does this version fall within the given range? -withinRange :: Version -> VersionRange -> Bool -withinRange _ AnyVersion = True -withinRange v1 (ThisVersion v2) = v1 == v2 -withinRange v1 (LaterVersion v2) = v1 `laterVersion` v2 -withinRange v1 (EarlierVersion v2) = v1 `earlierVersion` v2 -withinRange v1 (UnionVersionRanges v2 v3) - = v1 `withinRange` v2 || v1 `withinRange` v3 -withinRange v1 (IntersectVersionRanges v2 v3) - = v1 `withinRange` v2 && v1 `withinRange` v3 - -instance Text VersionRange where - disp AnyVersion = Disp.text "-any" - disp (ThisVersion v) = Disp.text "==" <> disp v - disp (LaterVersion v) = Disp.char '>' <> disp v - disp (EarlierVersion v) = Disp.char '<' <> disp v - disp (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) - | v1 == v2 = Disp.text ">=" <> disp v1 - disp (UnionVersionRanges (LaterVersion v2) (ThisVersion v1)) - | v1 == v2 = Disp.text ">=" <> disp v1 - disp (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2)) - | v1 == v2 = Disp.text "<=" <> disp v1 - disp (UnionVersionRanges (EarlierVersion v2) (ThisVersion v1)) - | v1 == v2 = Disp.text "<=" <> disp v1 - disp (UnionVersionRanges r1 r2) - = disp r1 <+> Disp.text "||" <+> disp r2 - disp (IntersectVersionRanges r1 r2) - = disp r1 <+> Disp.text "&&" <+> disp r2 - - parse = do - f1 <- factor - Parse.skipSpaces - (do - Parse.string "||" - Parse.skipSpaces - f2 <- factor - return (UnionVersionRanges f1 f2) - +++ - do - Parse.string "&&" - Parse.skipSpaces - f2 <- factor - return (IntersectVersionRanges f1 f2) - +++ - return f1) - where - factor = Parse.choice ((Parse.string "-any" >> return AnyVersion) : - map parseRangeOp rangeOps) - parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse - rangeOps = [ ("<", EarlierVersion), - ("<=", orEarlierVersion), - (">", LaterVersion), - (">=", orLaterVersion), - ("==", ThisVersion) ] - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -{-# DEPRECATED showVersion "use the Text class instead" #-} -showVersion :: Version -> String -showVersion = display - -{-# DEPRECATED parseVersion "use the Text class instead" #-} -parseVersion :: Parse.ReadP r Version -parseVersion = parse diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,8 @@ -Copyright (c) 2003-2007, Isaac Jones, Simon Marlow, Martin Sjögren, - Bjorn Bringert, Krasimir Angelov, - Malcolm Wallace, Ross Patterson, Ian Lynagh, - Duncan Coutts, Thomas Schilling +Copyright (c) 2003-2025, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. + +See */LICENSE for the copyright holders of the subcomponents. + All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs deleted file mode 100644 --- a/Language/Haskell/Extension.hs +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Extension --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Haskell language extensions - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Language.Haskell.Extension ( - Extension(..), - knownExtensions - ) where - -import Distribution.Text (Text(..)) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import qualified Data.Char as Char (isAlphaNum) -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) - --- ------------------------------------------------------------ --- * Extension --- ------------------------------------------------------------ - --- Note: if you add a new 'Extension': --- --- * also add it to the Distribution.Simple.X.languageExtensions lists --- (where X is each compiler: GHC, JHC, Hugs, NHC) --- --- * also to the 'knownExtensions' list below. --- --- * If the first character of the new extension is outside the range 'A' - 'U' --- (ie 'V'-'Z' or any non-uppercase-alphabetical char) then update the bounds --- of the 'extensionTable' below. - --- |This represents language extensions beyond Haskell 98 that are --- supported by some implementations, usually in some special mode. - -data Extension - = OverlappingInstances - | UndecidableInstances - | IncoherentInstances - | RecursiveDo - | ParallelListComp - | MultiParamTypeClasses - | NoMonomorphismRestriction - | FunctionalDependencies - | Rank2Types - | RankNTypes - | PolymorphicComponents - | ExistentialQuantification - | ScopedTypeVariables - | ImplicitParams - | FlexibleContexts - | FlexibleInstances - | EmptyDataDecls - | CPP - - | KindSignatures - | BangPatterns - | TypeSynonymInstances - | TemplateHaskell - | ForeignFunctionInterface - | Arrows - | Generics - | NoImplicitPrelude - | NamedFieldPuns - | PatternGuards - | GeneralizedNewtypeDeriving - - | ExtensibleRecords - | RestrictedTypeSynonyms - | HereDocuments - | MagicHash - | TypeFamilies - | StandaloneDeriving - - | UnicodeSyntax - | PatternSignatures - | UnliftedFFITypes - | LiberalTypeSynonyms - | TypeOperators ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - | RecordWildCards - | RecordPuns - | DisambiguateRecordFields - | OverloadedStrings - | GADTs - | NoMonoPatBinds - | RelaxedPolyRec - | ExtendedDefaultRules - | UnboxedTuples - | DeriveDataTypeable - | ConstrainedClassMethods - - | UnknownExtension String - deriving (Show, Read, Eq) - -knownExtensions :: [Extension] -knownExtensions = - [ OverlappingInstances - , UndecidableInstances - , IncoherentInstances - , RecursiveDo - , ParallelListComp - , MultiParamTypeClasses - , NoMonomorphismRestriction - , FunctionalDependencies - , Rank2Types - , RankNTypes - , PolymorphicComponents - , ExistentialQuantification - , ScopedTypeVariables - , ImplicitParams - , FlexibleContexts - , FlexibleInstances - , EmptyDataDecls - , CPP - - , KindSignatures - , BangPatterns - , TypeSynonymInstances - , TemplateHaskell - , ForeignFunctionInterface - , Arrows - , Generics - , NoImplicitPrelude - , NamedFieldPuns - , PatternGuards - , GeneralizedNewtypeDeriving - - , ExtensibleRecords - , RestrictedTypeSynonyms - , HereDocuments - , MagicHash - , TypeFamilies - , StandaloneDeriving - - , UnicodeSyntax - , PatternSignatures - , UnliftedFFITypes - , LiberalTypeSynonyms - , TypeOperators ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - , RecordWildCards - , RecordPuns - , DisambiguateRecordFields - , OverloadedStrings - , GADTs - , NoMonoPatBinds - , RelaxedPolyRec - , ExtendedDefaultRules - , UnboxedTuples - , DeriveDataTypeable - , ConstrainedClassMethods - ] - -instance Text Extension where - disp (UnknownExtension other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - extension <- Parse.munch1 Char.isAlphaNum - return (classifyExtension extension) - --- | 'read' for 'Extension'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'-'U'@ --- 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. --- -classifyExtension :: String -> Extension -classifyExtension string@(c:_) - | inRange (bounds extensionTable) c - = case lookup string (extensionTable ! c) of - Just extension -> extension - Nothing -> UnknownExtension string -classifyExtension string = UnknownExtension string - -extensionTable :: Array Char [(String, Extension)] -extensionTable = - accumArray (flip (:)) [] ('A', 'U') - [ (head str, (str, extension)) - | extension <- knownExtensions - , let str = show extension ] diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,114 +0,0 @@ -[Cabal home page](http://www.haskell.org/cabal/) - -Installation instructions for the Cabal library -=============================================== - -If you also want the `cabal` command line program then you need -the `cabal-install` package in addition to this library. - - -Installing as a user (no root or administer access) ---------------------------------------------------- - - ghc --make Setup - ./Setup configure --user - ./Setup build - ./Setup install - -Note the use of the `--user` flag at the configure step. - -This will install into `$HOME/.cabal/` on unix and into -`$Documents and Settings\$User\Application Data\cabal\` on Windows -If you want to install elsewhere use the `--prefix=` flag at the -configure step. - - -Installing as root / Administrator ----------------------------------- - - ghc --make Setup - ./Setup configure - ./Setup build - sudo ./Setup install - -This will install into `/usr/local` on unix and on Windows it will -install into `$ProgramFiles/Haskell`. If you want to install -elsewhere use the `--prefix=` flag at the configure step. - - -Working with older versions of GHC and Cabal -============================================ - -It is recommended just to leave any pre-existing version of Cabal -installed. In particular it is *essential* to keep the version that -came with GHC itself since other installed packages need it (eg the -"ghc" api package). - -Prior to GHC 6.4.2 however, GHC didn't deal particularly well with -having multiple versions of packages installed at once. So if you -are using GHC 6.4.1 or older and you have an older version of Cabal -installed, you probably just want to remove it: - - ghc-pkg unregister Cabal - -or if you had Cabal installed just for your user account then: - - ghc-pkg unregister Cabal --user - - -Your Help -========= - -To help us in the next round of development work it would be -enormously helpful to know from our users what their most pressing -problems are with Cabal and Hackage. You probably have a favourite -Cabal bug or limitation. Take a look at our [bug tracker]. Make sure -the problem is reported there and properly described. Comment on the -ticket to tell us how much of a problem the bug is for you. Add -yourself to the ticket's cc list so we can discuss requirements and -keep you informed on progress. For feature requests it is very -helpful if there is a description of how you would expect to -interact with the new feature. - -[bug tracker]: http://hackage.haskell.org/trac/hackage/ - - -Code -======= - -You can get the code from the web page; the version control system we -use is very open and welcoming to new developers. - -You can get the main development branch: - -> darcs get --partial http://darcs.haskell.org/cabal - -and you can get the stable 1.4 branch: - -> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.4 - - -Credits -======= - -Cabal Coders (in alphabetical order): - -- Krasimir Angelov -- Bjorn Bringert -- Duncan Coutts -- Isaac Jones -- David Himmelstrup (Lemmih) -- Simon Marlow -- Ross Patterson -- Thomas Schilling -- Martin Sjögren -- Malcolm Wallace -- and nearly 30 other people have contributed occasional patches - -Cabal spec: - -- Isaac Jones -- Simon Marlow -- Ross Patterson -- Simon Peyton Jones -- Malcolm Wallace diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,69 @@ +The Cabal library package +========================= + +See the [Cabal web site] for more information. + +If you also want the `cabal` command-line program, you need the +[cabal-install] package in addition to this library. + +[cabal-install]: ../cabal-install + +More information +================ + +Please see the [Cabal web site], the [user guide] and the [API +documentation]. There is additional information available on the +[development wiki]. + +[user guide]: http://www.haskell.org/cabal/users-guide +[API documentation]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html +[development wiki]: https://github.com/haskell/cabal/wiki + + +Bugs +==== + +Please report bugs and feature requests to Cabal's [bug tracker]. + + +Your help +--------- + +To help Cabal's development, it is enormously helpful to know from +Cabal's users what their most pressing problems are with Cabal and +[Hackage]. You may have a favourite Cabal bug or limitation. Look at +Cabal's [bug tracker]. Ensure that the problem is reported there and +adequately described. Comment on the issue to report how much of a +problem the bug is for you. Subscribe to the issue's notifications to +discuss requirements and keep informed on progress. For feature +requests, it is helpful if there is a description of how you would +expect to interact with the new feature. + +[Hackage]: http://hackage.haskell.org + + +Source code +=========== + +You can get the master development branch using: + + $ git clone https://github.com/haskell/cabal.git + + +Credits +======= + +See the `AUTHORS` file. + +Authors of the [original Cabal +specification](https://www.haskell.org/cabal/proposal/pkg-spec.pdf): + +- Isaac Jones +- Simon Marlow +- Ross Patterson +- Simon Peyton Jones +- Malcolm Wallace + + +[bug tracker]: https://github.com/haskell/cabal/issues +[Cabal web site]: http://www.haskell.org/cabal/ 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 @@ -8,3 +9,6 @@ -- on any previous installation. This also means we can use any new features -- immediately because we never have to worry about building Cabal with an -- older version of itself. +-- +-- NOTE 25/01/2015: Bootstrapping is disabled for now, see +-- https://github.com/haskell/cabal/issues/3003. diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,272 +0,0 @@ --*-change-log-*- - -1.5.x (current development version) - -1.4.0.2 Duncan Coutts August 2008 - * Fix executable stripping default - * Fix striping exes on OSX that export dynamic symbols (like ghc) - * Correct the order of arguments given by --prog-options= - * Fix corner case with overlapping user and global packages - * Fix for modules that use pre-processing and .hs-boot files - * Clarify some points in the user guide and readme text - * Fix verbosity flags passed to sub-command like haddock - * Fix sdist --snapshot - * Allow meta-packages that contain no modules or C code - * Make the generated Paths module -Wall clean on Windows - -1.4.0.1 Duncan Coutts June 2008 - * Fix a bug which caused '.' to always be in the sources search path - * Haddock-2.2 and later do now support the --hoogle flag - -1.4.0.0 Duncan Coutts June 2008 - * Rewritten command line handling support - * Command line completion with bash - * Better support for Haddock 2 - * Improved support for nhc98 - * Removed support for ghc-6.2 - * Haddock markup in .lhs files now supported - * Default colour scheme for highlighted source code - * Default prefix for --user installs is now $HOME/.cabal - * All .cabal files are treaded as UTF-8 and must be valid - * Many checks added for common mistakes - * New --package-db= option for specific package databases - * Many internal changes to support cabal-install - * Stricter parsing for version strings, eg dissalows "1.05" - * Improved user guide introduction - * Programatica support removed - * New options --program-prefix/suffix allows eg versioned programs - * Support packages that use .hs-boot files - * Fix sdist for Main modules that require preprocessing - * New configure -O flag with optimisation level 0--2 - * Provide access to "x-" extension fields through the Cabal api - * Added check for broken installed packages - * Added warning about using inconsistent versions of dependencies - * Strip binary executable files by default with an option to disable - * New options to add site-specific include and library search paths - * Lift the restriction that libraries must have exposed-modules - * Many bugs fixed. - * Many internal structural improvements and code cleanups - -1.2.4.0 Duncan Coutts June 2008 - * Released with GHC 6.8.3 - * Backported several fixes and minor improvements from Cabal-1.4 - * Use a default colour scheme for sources with hscolour >=1.9 - * Support --hyperlink-source for Haddock >= 2.0 - * Fix for running in a non-writable directory - * Add OSX -framework arguments when linking executables - * Updates to the user guide - * Allow build-tools names to include + and _ - * Export autoconfUserHooks and simpleUserHooks - * Export ccLdOptionsBuildInfo for Setup.hs scripts - * Export unionBuildInfo and make BuildInfo an instance of Monoid - * Fix to allow the 'main-is' module to use a pre-processor - -1.2.3.0 Duncan Coutts Nov 2007 - * Released with GHC 6.8.2 - * Includes full list of GHC language extensions - * Fix infamous "dist/conftest.c" bug - * Fix configure --interfacedir= - * Find ld.exe on Windows correctly - * Export PreProcessor constructor and mkSimplePreProcessor - * Fix minor bug in unlit code - * Fix some markup in the haddock docs - -1.2.2.0 Duncan Coutts Nov 2007 - * Released with GHC 6.8.1 - * Support haddock-2.0 - * Support building DSOs with GHC - * Require reconfiguring if the .cabal file has changed - * Fix os(windows) configuration test - * Fix building documentation - * Fix building packages on Solaris - * Other minor bug fixes - -1.2.1 Duncan Coutts Oct 2007 - * To be included in GHC 6.8.1 - * New field "cpp-options" used when preprocessing Haskell modules - * Fixes for hsc2hs when using ghc - * C source code gets compiled with -O2 by default - * OS aliases, to allow os(windows) rather than requiring os(mingw32) - * Fix cleaning of 'stub' files - * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" - * Build docs even when dependent packages docs are missing - * Allow the --html-dir to be specified at configure time - * Fix building with ghc-6.2 - * Other minor bug fixes and build fixes - -1.2.0 Duncan Coutts Sept 2007 - * To be included in GHC 6.8.x - * New configurations feature - * Can make haddock docs link to hilighted sources (with hscolour) - * New flag to allow linking to haddock docs on the web - * Supports pkg-config - * New field "build-tools" for tool dependencies - * Improved c2hs support - * Preprocessor output no longer clutters source dirs - * Seperate "includes" and "install-includes" fields - * Makefile command to generate makefiles for building libs with GHC - * New --docdir configure flag - * Generic --with-prog --prog-args configure flags - * Better default installation paths on Windows - * Install paths can be specified relative to each other - * License files now installed - * Initial support for NHC (incomplete) - * Consistent treatment of verbosity - * Reduced verbosity of configure step by default - * Improved helpfulness of output messages - * Help output now clearer and fits in 80 columns - * New setup register --gen-pkg-config flag for distros - * Major internal refactoring, hooks api has changed - * Dozens of bug fixes - -1.1.6.2 Duncan Coutts May 2007 - * Released with GHC 6.6.1 - * Handle windows text file encoding for .cabal files - * Fix compiling a executable for profiling that uses Template Haskell - * Other minor bug fixes and user guide clarifications - -1.1.6.1 Duncan Coutts Oct 2006 - * fix unlit code - * fix escaping in register.sh - -1.1.6 Duncan Coutts Oct 2006 - * Released with GHC 6.6 - * Added support for hoogle - * Allow profiling and normal builds of libs to be chosen indepentantly - * Default installation directories on Win32 changed - * Register haddock docs with ghc-pkg - * Get haddock to make hyperlinks to dependent package docs - * Added BangPatterns language extension - * Various bug fixes - -1.1.4 Duncan Coutts May 2006 - * Released with GHC 6.4.2 - * Better support for packages that need to install header files - * cabal-setup added, but not installed by default yet - * Implemented "setup register --inplace" - * Have packages exposed by default with ghc-6.2 - * It is no longer necessary to run 'configure' before 'clean' or 'sdist' - * Added support for ghc's -split-objs - * Initial support for JHC - * Ignore extension fields in .cabal files (fields begining with "x-") - * Some changes to command hooks API to improve consistency - * Hugs support improvements - * Added GeneralisedNewtypeDeriving language extension - * Added cabal-version field - * Support hidden modules with haddock - * Internal code refactoring - * More bug fixes - -1.1.3 Isaac Jones Sept 2005 - * WARNING: Interfaces not documented in the user's guide may - change in future releases. - * Move building of GHCi .o libs to the build phase rather than - register phase. (from Duncan Coutts) - * Use .tar.gz for source package extension - * Uses GHC instead of cpphs if the latter is not available - * Added experimental "command hooks" which completely override the - default behavior of a command. - * Some bugfixes - -1.1.1 Isaac Jones July 2005 - * WARNING: Interfaces not documented in the user's guide may - change in future releases. - * Handles recursive modules for GHC 6.2 and GHC 6.4. - * Added "setup test" command (Used with UserHook) - * implemented handling of _stub.{c,h,o} files - * Added support for profiling - * Changed install prefix of libraries (pref/pkgname-version - to prefix/pkgname-version/compname-version) - * Added pattern guards as a language extension - * Moved some functionality to Language.Haskell.Extension - * Register / unregister .bat files for windows - * Exposed more of the API - * Added support for the hide-all-packages flag in GHC > 6.4 - * Several bug fixes - -1.0 Isaac Jones March 11 2005 - * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 - * Some sanity checking - -0.5 Isaac Jones Wed Feb 19 2005 - * WARNING: this is a pre-release and the interfaces are still - likely to change until we reach a 1.0 release. - * Hooks interfaces changed - * Added preprocessors to user hooks - * No more executable-modules or hidden-modules. Use - "other-modules" instead. - * Certain fields moved into BuildInfo, much refactoring - * extra-libs -> extra-libraries - * Added --gen-script to configure and unconfigure. - * modules-ghc (etc) now ghc-modules (etc) - * added new fields including "synopsis" - * Lots of bug fixes - * spaces can sometimes be used instead of commas - * A user manual has appeared (Thanks, ross!) - * for ghc 6.4, configures versionsed depends properly - * more features to ./setup haddock - -0.4 Isaac Jones Sun Jan 16 2005 - - * Much thanks to all the awesome fptools hackers who have been - working hard to build the Haskell Cabal! - - * Interface Changes: - - ** WARNING: this is a pre-release and the interfaces are still - likely to change until we reach a 1.0 release. - - ** Instead of Package.description, you should name your - description files .cabal. In particular, we suggest - that you name it .cabal, but this is not enforced - (yet). Multiple .cabal files in the same directory is an error, - at least for now. - - ** ./setup install --install-prefix is gone. Use ./setup copy - --copy-prefix instead. - - ** The "Modules" field is gone. Use "hidden-modules", - "exposed-modules", and "executable-modules". - - ** Build-depends is now a package-only field, and can't go into - executable stanzas. Build-depends is a package-to-package - relationship. - - ** Some new fields. Use the Source. - - * New Features - - ** Cabal is now included as a package in the CVS version of - fptools. That means it'll be released as "-package Cabal" in - future versions of the compilers, and if you are a bleeding-edge - user, you can grab it from the CVS repository with the compilers. - - ** Hugs compatibility and NHC98 compatibility should both be - improved. - - ** Hooks Interface / Autoconf compatibility: Most of the hooks - interface is hidden for now, because it's not finalized. I have - exposed only "defaultMainWithHooks" and "defaultUserHooks". This - allows you to use a ./configure script to preprocess - "foo.buildinfo", which gets merged with "foo.cabal". In future - releases, we'll expose UserHooks, but we're definitely going to - change the interface to those. The interface to the two functions - I've exposed should stay the same, though. - - ** ./setup haddock is a baby feature which pre-processes the - source code with hscpp and runs haddock on it. This is brand new - and hardly tested, so you get to knock it around and see what you - think. - - ** Some commands now actually implement verbosity. - - ** The preprocessors have been tested a bit more, and seem to work - OK. Please give feedback if you use these. - -0.3 Isaac Jones Sun Jan 16 2005 - * Unstable snapshot release - * From now on, stable releases are even. - -0.2 Isaac Jones - - * Adds more HUGS support and preprocessor support. diff --git a/src/Distribution/Backpack/ComponentsGraph.hs b/src/Distribution/Backpack/ComponentsGraph.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/ComponentsGraph.hs @@ -0,0 +1,105 @@ +-- | See +module Distribution.Backpack.ComponentsGraph + ( ComponentsGraph + , ComponentsWithDeps + , mkComponentsGraph + , componentsGraphToList + , dispComponentsWithDeps + , componentCycleMsg + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (Graph, Node (..)) +import qualified Distribution.Compat.Graph as Graph +import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Utils.Generic + +import Distribution.Pretty (pretty) +import Text.PrettyPrint + +------------------------------------------------------------------------------ +-- Components graph +------------------------------------------------------------------------------ + +-- | A graph of source-level components by their source-level +-- dependencies +type ComponentsGraph = Graph (Node ComponentName Component) + +-- | A list of components associated with the source level +-- dependencies between them. +type ComponentsWithDeps = [(Component, [ComponentName])] + +-- | Pretty-print 'ComponentsWithDeps'. +dispComponentsWithDeps :: ComponentsWithDeps -> Doc +dispComponentsWithDeps graph = + vcat + [ hang + (text "component" <+> pretty (componentName c)) + 4 + (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps]) + | (c, cdeps) <- graph + ] + +-- | Create a 'Graph' of 'Component', or report a cycle if there is a +-- problem. +mkComponentsGraph + :: ComponentRequestedSpec + -> PackageDescription + -> Either [ComponentName] ComponentsGraph +mkComponentsGraph enabled pkg_descr = + let g = + Graph.fromDistinctList + [ N c (componentName c) (componentDeps c) + | c <- pkgBuildableComponents pkg_descr + , componentEnabled enabled c + ] + in case Graph.cycles g of + [] -> Right g + ccycles -> Left [componentName c | N c _ _ <- concat ccycles] + where + -- The dependencies for the given component + componentDeps component = + toolDependencies ++ libDependencies + where + bi = componentBuildInfo component + + toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi + + libDependencies = do + Dependency pkgname _ lns <- targetBuildDepends bi + guard (pkgname == packageName pkg_descr) + + ln <- NES.toList lns + return (CLibName ln) + +-- | Given the package description and a 'PackageDescription' (used +-- to determine if a package name is internal or not), sort the +-- components in dependency order (fewest dependencies first). This is +-- NOT necessarily the build order (although it is in the absence of +-- Backpack.) +componentsGraphToList + :: ComponentsGraph + -> ComponentsWithDeps +componentsGraphToList = + map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort + +-- | Error message when there is a cycle; takes the SCC of components. +componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc +componentCycleMsg pn cnames = + text "Components in the package" + <+> pretty pn + <+> text "depend on each other in a cyclic way:" + $$ text + ( intercalate + " depends on " + [ "'" ++ showComponentName cname ++ "'" + | cname <- cnames ++ maybeToList (safeHead cnames) + ] + ) diff --git a/src/Distribution/Backpack/Configure.hs b/src/Distribution/Backpack/Configure.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/Configure.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +-- | See +-- +-- WARNING: The contents of this module are HIGHLY experimental. +-- We may refactor it under you. +module Distribution.Backpack.Configure + ( configureComponentLocalBuildInfos + ) where + +import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () + +import Distribution.Backpack +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.Id +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ReadyComponent + +import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (Graph, IsNode (..)) +import qualified Distribution.Compat.Graph as Graph +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , emptyInstalledPackageInfo + ) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName) +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.MungedPackageName +import Distribution.Utils.LogProgress +import Distribution.Verbosity + +import Data.Either + ( lefts + ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Pretty +import Text.PrettyPrint + +------------------------------------------------------------------------------ +-- Pipeline +------------------------------------------------------------------------------ + +configureComponentLocalBuildInfos + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) +configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + deterministic + ipid_flag + cid_flag + pkg_descr + (prePkgDeps, promisedPkgDeps) + flags + instantiate_with + installedPackageSet + comp = do + -- NB: In single component mode, this returns a *single* component. + -- In this graph, the graph is NOT closed. + graph0 <- case mkComponentsGraph enabled pkg_descr of + Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) + Right g -> return (componentsGraphToList g) + infoProgress $ + hang + (text "Source component graph:") + 4 + (dispComponentsWithDeps graph0) + + let conf_pkg_map = + Map.fromListWith + Map.union + $ + -- Normal dependencies + [ ( pc_pkgname pkg + , Map.singleton + (pc_compname pkg) + ( AnnotatedId + { ann_id = pc_cid pkg + , ann_pid = packageId pkg + , ann_cname = pc_compname pkg + } + ) + ) + | pkg <- prePkgDeps + ] + ++ + -- Promised dependencies + [ (pkg, Map.singleton (ann_cname aid) aid) + | ConfiguredPromisedComponent pkg aid <- promisedPkgDeps + ] + graph1 <- + toConfiguredComponents + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + conf_pkg_map + (map fst graph0) + infoProgress $ + hang + (text "Configured component graph:") + 4 + (vcat (map dispConfiguredComponent graph1)) + + let shape_pkg_map = + Map.fromList + [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) + | pkg <- prePkgDeps + ] + `Map.union` Map.fromList + [ ( ann_id aid + , + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId (unComponentId (ann_id aid))) + ) + , emptyModuleShape + ) + ) + | ConfiguredPromisedComponent _ aid <- promisedPkgDeps + ] + uid_lookup def_uid + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid = + FullUnitId + (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ prettyShow uid) + where + uid = unDefUnitId def_uid + graph2 <- + toLinkedComponents + verbosity + (not (null promisedPkgDeps)) + uid_lookup + (package pkg_descr) + shape_pkg_map + graph1 + + infoProgress $ + hang + (text "Linked component graph:") + 4 + (vcat (map dispLinkedComponent graph2)) + + let pid_map = + Map.fromList $ + [ (pc_uid pkg, pc_munged_id pkg) + | pkg <- prePkgDeps + ] + ++ [ (Installed.installedUnitId pkg, mungedId pkg) + | (_, Module uid _) <- instantiate_with + , Just pkg <- + [ PackageIndex.lookupUnitId + installedPackageSet + (unDefUnitId uid) + ] + ] + subst = Map.fromList instantiate_with + graph3 = toReadyComponents pid_map subst graph2 + graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) + + infoProgress $ + hang + (text "Ready component graph:") + 4 + (vcat (map dispReadyComponent graph4)) + + toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4 + +------------------------------------------------------------------------------ +-- ComponentLocalBuildInfo +------------------------------------------------------------------------------ + +toComponentLocalBuildInfos + :: Compiler + -> InstalledPackageIndex -- FULL set + -> [ConfiguredPromisedComponent] + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress + ( [ComponentLocalBuildInfo] + , InstalledPackageIndex -- only relevant packages + ) +toComponentLocalBuildInfos + comp + installedPackageSet + promisedPkgDeps + pkg_descr + externalPkgDeps + graph = do + -- Check and make sure that every instantiated component exists. + -- We have to do this now, because prior to linking/instantiating + -- we don't actually know what the full set of 'UnitId's we need + -- are. + let + -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = + Graph.fromDistinctList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = + Graph.fromDistinctList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + local_graph = + fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $ + Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromDistinctList local_graph + + case Graph.broken fullIndex of + [] -> return () + -- If there are promised dependencies, we don't know what the dependencies + -- of these are and that can easily lead to a broken graph. So assume that + -- any promised package is not broken (ie all its dependencies, transitively, + -- will be there). That's a promise. + broken + | not (null promisedPkgDeps) -> return () + | otherwise -> + -- TODO: ppr this + dieProgress . text $ + "The following packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + -- TODO: Undupe. + ++ unlines + [ "installed package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Left pkg, deps) <- broken + ] + ++ unlines + [ "planned package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Right pkg, deps) <- broken + ] + + -- In this section, we'd like to look at the 'packageDependsIndex' + -- and see if we've picked multiple versions of the same + -- installed package (this is bad, because it means you might + -- get an error could not match foo-0.1:Type with foo-0.2:Type). + -- + -- What is pseudoTopPkg for? I have no idea. It was used + -- in the very original commit which introduced checking for + -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012, + -- and then moved out of PackageIndex and put here later. + -- TODO: Try this code without it... + -- + -- TODO: Move this into a helper function + -- + -- TODO: This is probably wrong for Backpack + let pseudoTopPkg :: InstalledPackageInfo + pseudoTopPkg = + emptyInstalledPackageInfo + { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr) + , Installed.sourcePackageId = packageId pkg_descr + , Installed.depends = map pc_uid externalPkgDeps + } + case PackageIndex.dependencyInconsistencies + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of + [] -> return () + inconsistencies -> + warnProgress $ + hang + ( text "This package indirectly depends on multiple versions of the same" + <+> text "package. This is very likely to cause a compile failure." + ) + 2 + ( vcat + [ text "package" + <+> pretty (packageName user) + <+> parens (pretty (installedUnitId user)) + <+> text "requires" + <+> pretty inst + | (_dep_key, insts) <- inconsistencies + , (inst, users) <- insts + , user <- users + ] + ) + let clbis = mkLinkedComponentsLocalBuildInfo comp graph + -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) + return (clbis, packageDependsIndex) + +-- Build ComponentLocalBuildInfo for each component we are going +-- to build. +-- +-- This conversion is lossy; we lose some invariants from ReadyComponent +mkLinkedComponentsLocalBuildInfo + :: Compiler + -> [ReadyComponent] + -> [ComponentLocalBuildInfo] +mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs + where + internalUnits = Set.fromList (map rc_uid rcs) + isInternal x = Set.member x internalUnits + go rc = + case rc_component rc of + CLib lib -> + let convModuleExport (modname', (Module uid modname)) + | this_uid == unDefUnitId uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule + modname' + (Just (OpenModule (DefiniteUnitId uid) modname)) + convOpenModuleExport (modname', modu@(OpenModule uid modname)) + | uid == this_open_uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule modname' (Just modu) + convOpenModuleExport (_, OpenModuleVar _) = + error "convOpenModuleExport: top-level modvar" + exports = + -- Loses invariants + case rc_i rc of + Left indefc -> + map convOpenModuleExport $ + Map.toList (indefc_provides indefc) + Right instc -> + map convModuleExport $ + Map.toList (instc_provides instc) + insts = + case rc_i rc of + Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc] + Right instc -> + [ (m, OpenModule (DefiniteUnitId uid') m') + | (m, Module uid' m') <- instc_insts instc + ] + + compat_name = MungedPackageName (packageName rc) (libName lib) + compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + in LibComponentLocalBuildInfo + { componentPackageDeps = cpds + , componentUnitId = this_uid + , componentComponentId = this_cid + , componentInstantiatedWith = insts + , componentIsIndefinite_ = is_indefinite + , componentLocalName = cname + , componentInternalDeps = internal_deps + , componentExeDeps = exe_deps + , componentIncludes = includes + , componentExposedModules = exports + , componentIsPublic = rc_public rc + , componentCompatPackageKey = compat_key + , componentCompatPackageName = compat_name + } + CFLib _ -> + FLibComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CExe _ -> + ExeComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + where + this_uid = rc_uid rc + this_open_uid = rc_open_uid rc + this_cid = rc_cid rc + cname = componentName (rc_component rc) + cpds = rc_depends rc + exe_deps = map ann_id $ rc_exe_deps rc + is_indefinite = + case rc_i rc of + Left _ -> True + Right _ -> False + includes = + map (\ci -> (ci_id ci, ci_renaming ci)) $ + case rc_i rc of + Left indefc -> + indefc_includes indefc + Right instc -> + map + (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)}) + (instc_includes instc) + internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/src/Distribution/Backpack/ConfiguredComponent.hs b/src/Distribution/Backpack/ConfiguredComponent.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/ConfiguredComponent.hs @@ -0,0 +1,349 @@ +-- | See +module Distribution.Backpack.ConfiguredComponent + ( ConfiguredComponent (..) + , cc_name + , cc_cid + , cc_pkgid + , toConfiguredComponent + , toConfiguredComponents + , dispConfiguredComponent + , ConfiguredComponentMap + , extendConfiguredComponentMap + -- TODO: Should go somewhere else + , newPackageDepsBehaviour + ) where + +import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () + +import Distribution.Backpack.Id + +import Distribution.CabalSpecVersion +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Flag (Flag) +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import Distribution.Utils.Generic +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Compat.NonEmptySet as NonEmptySet +import Distribution.Pretty +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$)) +import qualified Text.PrettyPrint as PP + +-- | A configured component, we know exactly what its 'ComponentId' is, +-- and the 'ComponentId's of the things it depends on. +data ConfiguredComponent = ConfiguredComponent + { cc_ann_id :: AnnotatedId ComponentId + -- ^ Unique identifier of component, plus extra useful info. + , cc_component :: Component + -- ^ The fragment of syntax from the Cabal file describing this + -- component. + , cc_public :: Bool + -- ^ Is this the public library component of the package? + -- (If we invoke Setup with an instantiation, this is the + -- component the instantiation applies to.) + -- Note that in one-component configure mode, this is + -- always True, because any component is the "public" one.) + , cc_exe_deps :: [AnnotatedId ComponentId] + -- ^ Dependencies on executables from @build-tools@ and + -- @build-tool-depends@. + , cc_includes :: [ComponentInclude ComponentId IncludeRenaming] + -- ^ The mixins of this package, including both explicit (from + -- the @mixins@ field) and implicit (from @build-depends@). Not + -- mix-in linked yet; component configuration only looks at + -- 'ComponentId's. + } + +-- | Uniquely identifies a configured component. +cc_cid :: ConfiguredComponent -> ComponentId +cc_cid = ann_id . cc_ann_id + +-- | The package this component came from. +cc_pkgid :: ConfiguredComponent -> PackageId +cc_pkgid = ann_pid . cc_ann_id + +-- | The 'ComponentName' of a component; this uniquely identifies +-- a fragment of syntax within a specified Cabal file describing the +-- component. +cc_name :: ConfiguredComponent -> ComponentName +cc_name = ann_cname . cc_ann_id + +-- | Pretty-print a 'ConfiguredComponent'. +dispConfiguredComponent :: ConfiguredComponent -> Doc +dispConfiguredComponent cc = + hang + (text "component" <+> pretty (cc_cid cc)) + 4 + ( vcat + [ hsep $ + [ text "include" + , pretty (ci_id incl) + , pretty (ci_renaming incl) + ] + | incl <- cc_includes cc + ] + ) + +-- | Construct a 'ConfiguredComponent', given that the 'ComponentId' +-- and library/executable dependencies are known. The primary +-- work this does is handling implicit @backpack-include@ fields. +mkConfiguredComponent + :: PackageDescription + -> ComponentId + -> [AnnotatedId ComponentId] -- lib deps + -> [AnnotatedId ComponentId] -- exe deps + -> Component + -> LogProgress ConfiguredComponent +mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do + -- Resolve each @mixins@ into the actual dependency + -- from @lib_deps@. + explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do + aid <- case Map.lookup (pn, CLibName ln) deps_map of + Nothing -> + dieProgress $ + text "Mix-in refers to non-existent library" + <+> quotes (pretty pn <<>> prettyLN ln) + $$ text "(did you forget to add the package to build-depends?)" + Just r -> return r + return + ComponentInclude + { ci_ann_id = aid + , ci_renaming = rns + , ci_implicit = False + } + + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + let used_explicitly = Set.fromList (map ci_id explicit_includes) + implicit_includes = + map + ( \aid -> + ComponentInclude + { ci_ann_id = aid + , ci_renaming = defaultIncludeRenaming + , ci_implicit = True + } + ) + $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps + + return + ConfiguredComponent + { cc_ann_id = + AnnotatedId + { ann_id = this_cid + , ann_pid = package pkg_descr + , ann_cname = componentName component + } + , cc_component = component + , cc_public = is_public + , cc_exe_deps = exe_deps + , cc_includes = explicit_includes ++ implicit_includes + } + where + bi :: BuildInfo + bi = componentBuildInfo component + + prettyLN :: LibraryName -> Doc + prettyLN LMainLibName = PP.empty + prettyLN (LSubLibName n) = PP.colon <<>> pretty n + + deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId) + deps_map = + Map.fromList + [ ((packageName dep, ann_cname dep), dep) + | dep <- lib_deps + ] + + is_public = componentName component == CLibName LMainLibName + +type ConfiguredComponentMap = + Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + +toConfiguredComponent + :: PackageDescription + -> ComponentId + -> ConfiguredComponentMap + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then fmap concat $ + forM (targetBuildDepends bi) $ + \(Dependency name _ sublibs) -> do + case Map.lookup name lib_dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text "package" + <+> pretty name + Just pkg -> do + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib + in case Map.lookup comp pkg of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text (showLibraryName lib) + <+> text "from" + <+> pretty name + Just v -> return v + else return old_style_lib_deps + mkConfiguredComponent + pkg_descr + this_cid + lib_deps + exe_deps + component + where + bi = componentBuildInfo component + -- lib_dep_map contains a mix of internal and external deps. + -- We want all the public libraries (dep_cn == CLibName) + -- of all external deps (dep /= pn). Note that this + -- excludes the public library of the current package: + -- this is not supported by old-style deps behavior + -- because it would imply a cyclic dependency for the + -- library itself. + old_style_lib_deps = + [ e + | (pn, comp_map) <- Map.toList lib_dep_map + , pn /= packageName pkg_descr + , (cn, e) <- Map.toList comp_map + , cn == CLibName LMainLibName + ] + -- We have to nub here, because 'getAllToolDependencies' may return + -- duplicates (see #4986). (NB: This is not needed for lib_deps, + -- since those elaborate into includes, for which there explicitly + -- may be multiple instances of a package) + exe_deps = + ordNub $ + [ exe + | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi + , -- The error suppression here is important, because in general + -- we won't know about external dependencies (e.g., 'happy') + -- which the package is attempting to use (those deps are only + -- fed in when cabal-install uses this codepath.) + -- TODO: Let cabal-install request errors here + Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] + ] + +-- | Also computes the 'ComponentId', and sets cc_public if necessary. +-- This is Cabal-only; cabal-install won't use this. +toConfiguredComponent' + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> PackageDescription + -> Bool -- deterministic + -> Flag String -- configIPID (todo: remove me) + -> Flag ComponentId -- configCID + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + dep_map + component = do + cc <- + toConfiguredComponent + pkg_descr + this_cid + dep_map + dep_map + component + return $ + if use_external_internal_deps + then cc{cc_public = True} + else cc + where + -- TODO: pass component names to it too! + this_cid = + computeComponentId + deterministic + ipid_flag + cid_flag + (package pkg_descr) + (componentName component) + (Just (deps, flags)) + deps = + [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m + ] + +extendConfiguredComponentMap + :: ConfiguredComponent + -> ConfiguredComponentMap + -> ConfiguredComponentMap +extendConfiguredComponentMap cc = + Map.insertWith + Map.union + (pkgName (cc_pkgid cc)) + (Map.singleton (cc_name cc) (cc_ann_id cc)) + +-- Compute the 'ComponentId's for a graph of 'Component's. The +-- list of internal components must be topologically sorted +-- based on internal package dependencies, so that any internal +-- dependency points to an entry earlier in the list. +-- +-- TODO: This function currently restricts the input configured components to +-- one version per package, by using the type ConfiguredComponentMap. It cannot +-- be used to configure a component that depends on one version of a package for +-- a library and another version for a build-tool. +toConfiguredComponents + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ConfiguredComponentMap + -> [Component] + -> LogProgress [ConfiguredComponent] +toConfiguredComponents + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + dep_map + comps = + fmap snd (mapAccumM go dep_map comps) + where + go m component = do + cc <- + toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + m + component + return (extendConfiguredComponentMap cc m, cc) + +newPackageDepsBehaviourMinVersion :: CabalSpecVersion +newPackageDepsBehaviourMinVersion = CabalSpecV1_8 + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/src/Distribution/Backpack/DescribeUnitId.hs b/src/Distribution/Backpack/DescribeUnitId.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/DescribeUnitId.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + +module Distribution.Backpack.DescribeUnitId where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Stack +import Distribution.ModuleName +import Distribution.Pretty +import Distribution.Simple.Utils +import Distribution.Types.ComponentName +import Distribution.Types.PackageId +import Distribution.Verbosity + +import Text.PrettyPrint + +-- Unit identifiers have a well defined, machine-readable format, +-- but this format isn't very user-friendly for users. This +-- module defines some functions for solving common rendering +-- problems one has for displaying these. +-- +-- There are three basic problems we tackle: +-- +-- - Users don't want to see pkg-0.5-inplace-libname, +-- they want to see "library 'libname' from 'pkg-0.5'" +-- +-- - Users don't want to see the raw component identifier, which +-- usually contains a wordy hash that doesn't matter. +-- +-- - Users don't want to see a hash of the instantiation: they +-- want to see the actual instantiation, and they want it in +-- interpretable form. +-- + +-- | Print a Setup message stating (1) what operation we are doing, +-- for (2) which component (with enough details to uniquely identify +-- the build in question.) +setupMessage' + :: Pretty a + => Verbosity + -> String + -- ^ Operation being done (capitalized), on: + -> PackageIdentifier + -- ^ Package + -> ComponentName + -- ^ Component name + -> Maybe [(ModuleName, a)] + -- ^ Instantiation, if available. + -- Polymorphic to take + -- 'OpenModule' or 'Module' + -> IO () +setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do + noticeDoc verbosity $ + case mb_insts of + Just insts + | not (null insts) -> + hang + (msg_doc <+> text "instantiated with") + 2 + ( vcat + [ pretty k <+> text "=" <+> pretty v + | (k, v) <- insts + ] + ) + $$ for_doc + _ -> + msg_doc <+> for_doc + where + msg_doc = text msg <+> text (showComponentName cname) + for_doc = text "for" <+> pretty pkgid <<>> text "..." diff --git a/src/Distribution/Backpack/FullUnitId.hs b/src/Distribution/Backpack/FullUnitId.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/FullUnitId.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Backpack.FullUnitId + ( FullUnitId (..) + , FullDb + , expandOpenUnitId + , expandUnitId + ) where + +import Distribution.Backpack +import Distribution.Compat.Prelude +import Distribution.Types.ComponentId + +-- Unlike OpenUnitId, which could direct to a UnitId. +data FullUnitId = FullUnitId ComponentId OpenModuleSubst + deriving (Show, Generic) + +type FullDb = DefUnitId -> FullUnitId + +expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId +expandOpenUnitId _db (IndefFullUnitId cid subst) = + FullUnitId cid subst +expandOpenUnitId db (DefiniteUnitId uid) = + expandUnitId db uid + +expandUnitId :: FullDb -> DefUnitId -> FullUnitId +expandUnitId db uid = db uid diff --git a/src/Distribution/Backpack/Id.hs b/src/Distribution/Backpack/Id.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/Id.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | See +module Distribution.Backpack.Id + ( computeComponentId + , computeCompatPackageKey + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId +import Distribution.Utils.Base62 +import Distribution.Version + +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty + ( prettyShow + ) + +-- | This method computes a default, "good enough" 'ComponentId' +-- for a package. The intent is that cabal-install (or the user) will +-- specify a more detailed IPID via the @--ipid@ flag if necessary. +computeComponentId + :: Bool -- deterministic mode + -> Flag String + -> Flag ComponentId + -> PackageIdentifier + -> ComponentName + -- This is used by cabal-install's legacy codepath + -> Maybe ([ComponentId], FlagAssignment) + -> ComponentId +computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concatenating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash_suffix + | Just (dep_ipids, flags) <- mb_details = + "-" + ++ hashToBase62 + -- For safety, include the package + version here + -- for GHC 7.10, where just the hash is used as + -- the package key + ( prettyShow pid + ++ show dep_ipids + ++ show flags + ) + | otherwise = "" + generated_base = prettyShow pid ++ hash_suffix + explicit_base cid0 = + fromPathTemplate + ( InstallDirs.substPathTemplate + env + (toPathTemplate cid0) + ) + where + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + env = packageTemplateEnv pid (mkUnitId "") + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 + NoFlag + | deterministic -> prettyShow pid + | otherwise -> generated_base + in case mb_cid of + Flag cid -> cid + NoFlag -> + mkComponentId $ + actual_base + ++ ( case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ unUnqualComponentName s + ) + +-- | In GHC 8.0, the string we pass to GHC to use for symbol +-- names for a package can be an arbitrary, IPID-compatible string. +-- However, prior to GHC 8.0 there are some restrictions on what +-- format this string can be (due to how ghc-pkg parsed the key): +-- +-- 1. In GHC 7.10, the string had either be of the form +-- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated +-- prefix and ABCD is two base-64 encoded 64-bit integers, +-- or a GHC 7.8 style identifier. +-- +-- 2. In GHC 7.8, the string had to be a valid package identifier +-- like foo-0.1. +-- +-- So, the problem is that Cabal, in general, has a general IPID, +-- but needs to figure out a package key / package ID that the +-- old ghc-pkg will actually accept. But there's an EVERY WORSE +-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx +-- as if it were a package identifier, which means it will SILENTLY +-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.) +-- So we must CONNIVE to ensure that we don't pick something that +-- looks like this. +-- +-- So this function attempts to define a mapping into the old formats. +-- +-- The mapping for GHC 7.8 and before: +-- +-- * We use the *compatibility* package name and version. For +-- public libraries this is just the package identifier; for +-- internal libraries, it's something like "z-pkgname-z-libname-0.1". +-- See 'computeCompatPackageName' for more details. +-- +-- The mapping for GHC 7.10: +-- +-- * For CLibName: +-- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would +-- validly parse as a package key, we pass "ABCDEF". (NB: not +-- all hashes parse this way, because GHC 7.10 mandated that +-- these hashes be two base-62 encoded 64 bit integers), +-- but hashes that Cabal generated using 'computeComponentId' +-- are guaranteed to have this form. +-- +-- If it is not of this form, we rehash the IPID into the +-- correct form and pass that. +-- +-- * For sub-components, we rehash the IPID into the correct format +-- and pass that. +computeCompatPackageKey + :: Compiler + -> MungedPackageName + -> Version + -> UnitId + -> String +computeCompatPackageKey comp pkg_name pkg_version uid + | not (packageKeySupported comp || unitIdSupported comp) = + prettyShow pkg_name ++ "-" ++ prettyShow pkg_version + | not (unifiedIPIDRequired comp) = + let str = unUnitId uid -- assume no Backpack support + mb_verbatim_key = + case simpleParsec str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | prettyShow pid0 == str -> Just str + _ -> Nothing + mb_truncated_key = + let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) + | otherwise = prettyShow uid diff --git a/src/Distribution/Backpack/LinkedComponent.hs b/src/Distribution/Backpack/LinkedComponent.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/LinkedComponent.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | See +module Distribution.Backpack.LinkedComponent + ( LinkedComponent (..) + , lc_insts + , lc_uid + , lc_cid + , lc_pkgid + , toLinkedComponent + , toLinkedComponents + , dispLinkedComponent + , LinkedComponentMap + , extendLinkedComponentMap + ) where + +import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () + +import Distribution.Backpack +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.MixLink +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.PreModuleShape +import Distribution.Backpack.UnifyM +import Distribution.Utils.MapAccum + +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import Distribution.Utils.LogProgress +import Distribution.Verbosity + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Pretty (pretty) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$)) + +-- | A linked component is a component that has been mix-in linked, at +-- which point we have determined how all the dependencies of the +-- component are explicitly instantiated (in the form of an OpenUnitId). +-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which +-- is then instantiated into 'ReadyComponent'. +data LinkedComponent = LinkedComponent + { lc_ann_id :: AnnotatedId ComponentId + -- ^ Uniquely identifies linked component + , lc_component :: Component + -- ^ Corresponds to 'cc_component'. + , lc_exe_deps :: [AnnotatedId OpenUnitId] + -- ^ @build-tools@ and @build-tool-depends@ dependencies. + -- Corresponds to 'cc_exe_deps'. + , lc_public :: Bool + -- ^ Is this the public library of a package? Corresponds to + -- 'cc_public'. + , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Corresponds to 'cc_includes', but (1) this does not contain + -- includes of signature packages (packages with no exports), + -- and (2) the 'ModuleRenaming' for requirements (stored in + -- 'IncludeRenaming') has been removed, as it is reflected in + -- 'OpenUnitId'.) + , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Like 'lc_includes', but this specifies includes on + -- signature packages which have no exports. + , lc_shape :: ModuleShape + -- ^ The module shape computed by mix-in linking. This is + -- newly computed from 'ConfiguredComponent' + } + +-- | Uniquely identifies a 'LinkedComponent'. Corresponds to +-- 'cc_cid'. +lc_cid :: LinkedComponent -> ComponentId +lc_cid = ann_id . lc_ann_id + +-- | Corresponds to 'cc_pkgid'. +lc_pkgid :: LinkedComponent -> PackageId +lc_pkgid = ann_pid . lc_ann_id + +-- | The 'OpenUnitId' of this component in the "default" instantiation. +-- See also 'lc_insts'. 'LinkedComponent's cannot be instantiated +-- (e.g., there is no 'ModSubst' instance for them). +lc_uid :: LinkedComponent -> OpenUnitId +lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc + +-- | The instantiation of 'lc_uid'; this always has the invariant +-- that it is a mapping from a module name @A@ to @@ (the hole A). +lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] +lc_insts lc = + [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires (lc_shape lc)) + ] + +dispLinkedComponent :: LinkedComponent -> Doc +dispLinkedComponent lc = + hang (text "unit" <+> pretty (lc_uid lc)) 4 $ + vcat + [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) + | incl <- lc_includes lc + ] + $+$ vcat + [ text "signature include" <+> pretty (ci_id incl) + | incl <- lc_sig_includes lc + ] + $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) + +instance Package LinkedComponent where + packageId = lc_pkgid + +toLinkedComponent + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent + verbosity + anyPromised + db + this_pid + pkg_map + ConfiguredComponent + { cc_ann_id = aid@AnnotatedId{ann_id = this_cid} + , cc_component = component + , cc_exe_deps = exe_deps + , cc_public = is_public + , cc_includes = cid_includes + } = do + let + -- The explicitly specified requirements, provisions and + -- reexports from the Cabal file. These are only non-empty for + -- libraries; everything else is trivial. + ( src_reqs :: [ModuleName] + , src_provs :: [ModuleName] + , src_reexports :: [ModuleReexport] + ) = + case component of + CLib lib -> + ( signatures lib + , exposedModules lib + , reexportedModules lib + ) + _ -> ([], [], []) + src_hidden = otherModules (componentBuildInfo component) + + -- Take each included ComponentId and resolve it into an + -- \*unlinked* unit identity. We will use unification (relying + -- on the ModuleShape) to resolve these into linked identities. + unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] + unlinked_includes = + [ ComponentInclude (fmap lookupUid dep_aid) rns i + | ComponentInclude dep_aid rns i <- cid_includes + ] + + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) + lookupUid cid = + fromMaybe + (error "linkComponent: lookupUid") + (Map.lookup cid pkg_map) + + let orErr (Right x) = return x + orErr (Left [err]) = dieProgress err + orErr (Left errs) = do + dieProgress + ( vcat + ( intersperse + (text "") -- double newline! + [hang (text "-") 2 err | err <- errs] + ) + ) + + -- Pre-shaping + let pre_shape = + mixLinkPreModuleShape $ + PreModuleShape + { preModShapeProvides = Set.fromList (src_provs ++ src_hidden) + , preModShapeRequires = Set.fromList src_reqs + } + : [ renamePreModuleShape (toPreModuleShape sh) rns + | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes + ] + reqs = preModShapeRequires pre_shape + insts = + [ (req, OpenModuleVar req) + | req <- Set.toList reqs + ] + this_uid = IndefFullUnitId this_cid . Map.fromList $ insts + + -- OK, actually do unification + -- TODO: the unification monad might return errors, in which + -- case we have to deal. Use monadic bind for now. + ( linked_shape0 :: ModuleScope + , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + ) <- + orErr $ runUnifyM verbosity this_cid db $ do + -- The unification monad is implemented using mutable + -- references. Thus, we must convert our *pure* data + -- structures into mutable ones to perform unification. + + let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) + convertMod from m = do + m_u <- convertModule (OpenModule this_uid m) + return (Map.singleton m [WithSource (from m) m_u], Map.empty) + -- Handle 'exposed-modules' + exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs + -- Handle 'other-modules' + other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden + + -- Handle 'signatures' + let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) + convertReq req = do + req_u <- convertModule (OpenModuleVar req) + return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) + req_shapes_u <- traverse convertReq src_reqs + + -- Handle 'mixins' + (incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes) + + failIfErrs -- Prevent error cascade + -- Mix-in link everything! mixLink is the real workhorse. + shape_u <- + mixLink $ + exposed_mod_shapes_u + ++ other_mod_shapes_u + ++ req_shapes_u + ++ incl_shapes_u + + -- src_reqs_u <- traverse convertReq src_reqs + -- Read out all the final results by converting back + -- into a pure representation. + let convertIncludeU (ComponentInclude dep_aid rns i) = do + let component_name = pretty $ ann_cname dep_aid + uid <- convertUnitIdU (ann_id dep_aid) component_name + return + ( ComponentInclude + { ci_ann_id = dep_aid{ann_id = uid} + , ci_renaming = rns + , ci_implicit = i + } + ) + + shape <- convertModuleScopeU shape_u + let (includes_u, sig_includes_u) = partitionEithers all_includes_u + incls <- traverse convertIncludeU includes_u + sig_incls <- traverse convertIncludeU sig_includes_u + return (shape, incls, sig_incls) + + let isNotLib (CLib _) = False + isNotLib _ = True + when (not (Set.null reqs) && isNotLib component) $ + dieProgress $ + hang + (text "Non-library component has unfilled requirements:") + 4 + (vcat [pretty req | req <- Set.toList reqs]) + + -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg + -- won't allow it (since someone could directly synthesize + -- an 'InstalledPackageInfo' that violates abstraction.) + -- Though, maybe it should be relaxed? + let src_hidden_set = Set.fromList src_hidden + linked_shape = + linked_shape0 + { modScopeProvides = + -- Would rather use withoutKeys but need BC + Map.filterWithKey + (\k _ -> not (k `Set.member` src_hidden_set)) + (modScopeProvides linked_shape0) + } + + -- OK, compute the reexports + -- TODO: This code reports the errors for reexports one reexport at + -- a time. Better to collect them all up and report them all at + -- once. + let hdl :: [Either Doc a] -> LogProgress [a] + hdl es = + case partitionEithers es of + ([], rs) -> return rs + (ls, _) -> + dieProgress $ + hang + (text "Problem with module re-exports:") + 2 + (vcat [hang (text "-") 2 l | l <- ls]) + reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do + case Map.lookup from (modScopeProvides linked_shape) of + Just cands@(x0 : xs0) -> do + -- Make sure there is at least one candidate + (x, xs) <- + case mb_pn of + Just pn -> + let matches_pn (FromMixins pn' _ _) = pn == pn' + matches_pn (FromBuildDepends pn' _) = pn == pn' + matches_pn (FromExposedModules _) = pn == packageName this_pid + matches_pn (FromOtherModules _) = pn == packageName this_pid + matches_pn (FromSignatures _) = pn == packageName this_pid + in case filter (matches_pn . getSource) cands of + (x1 : xs1) -> return (x1, xs1) + _ -> Left (brokenReexportMsg reex) + Nothing -> return (x0, xs0) + -- Test that all the candidates are consistent + case filter (\x' -> unWithSource x /= unWithSource x') xs of + [] -> return () + _ -> Left $ ambiguousReexportMsg reex x xs + return (to, Just (unWithSource x)) + _ -> + -- Can't resolve it right now.. carry on with the assumption it will be resolved + -- dynamically later by an in-memory package which hasn't been installed yet. + if anyPromised + then return (to, Nothing) + else -- But if nothing is promised, eagerly report an error, as we already know everything. + Left (brokenReexportMsg reex) + + -- TODO: maybe check this earlier; it's syntactically obvious. + let build_reexports m (k, v) + | Map.member k m = + dieProgress $ + hsep + [text "Module name ", pretty k, text " is exported multiple times."] + | otherwise = return (Map.insert k v m) + provs <- + foldM build_reexports Map.empty $ + -- TODO: doublecheck we have checked for + -- src_provs duplicates already! + -- These are normal module exports. + [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs] + ++ + -- These are reexports, which we managed to resolve to something in an external package. + [(mn_new, om) | (mn_new, Just om) <- reexports_list] + ++ + -- These ones.. we didn't resolve but also we might not have to + -- resolve them because they could come from a promised unit, + -- which we don't know anything about yet. GHC will resolve + -- these itself when it is dealing with the multi-session. + -- These ones will not be built, registered and put + -- into a package database, we only need them to make it as far + -- as generating GHC options where the info will be used to + -- pass the reexported-module option to GHC. + + -- We also know that in the case there are promised units that + -- we will not be doing anything to do with backpack like + -- unification etc.. + [ ( mod_name + , OpenModule + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId "fake") + ) + ) + mod_name + ) + | (mod_name, Nothing) <- reexports_list + ] + + let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) + + -- See Note Note [Signature package special case] + let (linked_includes, linked_sig_includes) + | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) + | otherwise = (linked_includes0, linked_sig_includes0) + + return $ + LinkedComponent + { lc_ann_id = aid + , lc_component = component + , lc_public = is_public + , -- These must be executables + lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps + , lc_shape = final_linked_shape + , lc_includes = linked_includes + , lc_sig_includes = linked_sig_includes + } + +-- Note [Signature package special case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Suppose we have p-indef, which depends on str-sig and inherits +-- the hole from that signature package. When we instantiate p-indef, +-- it's a bit pointless to also go ahead and build str-sig, because +-- str-sig cannot possibly have contributed any code to the package +-- in question. Furthermore, because the signature was inherited to +-- p-indef, if we test matching against p-indef, we also have tested +-- matching against p-sig. In fact, skipping p-sig is *mandatory*, +-- because p-indef may have thinned it (so that an implementation may +-- match p-indef but not p-sig.) +-- +-- However, suppose that we have a package which mixes together str-sig +-- and str-bytestring, with the intent of *checking* that str-sig is +-- implemented by str-bytestring. Here, it's quite important to +-- build an instantiated str-sig, since that is the only way we will +-- actually end up testing if the matching works. Note that this +-- admonition only applies if the package has NO requirements; if it +-- has any requirements, we will typecheck it as an indefinite +-- package, at which point the signature includes will be passed to +-- GHC who will in turn actually do the checking to make sure they +-- are instantiated correctly. + +-- Handle mix-in linking for components. In the absence of Backpack, +-- every ComponentId gets converted into a UnitId by way of SimpleUnitId. +toLinkedComponents + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't + -- find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps = + fmap snd (mapAccumM go lc_map0 comps) + where + go + :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- + addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity anyPromised db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) + +type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) + +extendLinkedComponentMap + :: LinkedComponent + -> LinkedComponentMap + -> LinkedComponentMap +extendLinkedComponentMap lc m = + Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m + +brokenReexportMsg :: ModuleReexport -> Doc +brokenReexportMsg (ModuleReexport (Just pn) from _to) = + vcat + [ text "The package" <+> quotes (pretty pn) + , text "does not export a module" <+> quotes (pretty from) + ] +brokenReexportMsg (ModuleReexport Nothing from _to) = + vcat + [ text "The module" <+> quotes (pretty from) + , text "is not exported by any suitable package." + , text "It occurs in neither the 'exposed-modules' of this package," + , text "nor any of its 'build-depends' dependencies." + ] + +ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc +ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = + vcat + [ text "Ambiguous reexport" <+> quotes (pretty from) + , hang + (text "It could refer to either:") + 2 + (vcat (msg : msgs)) + , help_msg mb_pn + ] + where + msg = text " " <+> displayModuleWithSource y1 + msgs = [text "or" <+> displayModuleWithSource y | y <- ys] + help_msg Nothing = + -- TODO: This advice doesn't help if the ambiguous exports + -- come from a package named the same thing + vcat + [ text "The ambiguity can be resolved by qualifying the" + , text "re-export with a package name." + , text "The syntax is 'packagename:ModuleName [as NewName]'." + ] + -- Qualifying won't help that much. + help_msg (Just _) = + vcat + [ text "The ambiguity can be resolved by using the" + , text "mixins field to rename one of the module" + , text "names differently." + ] + displayModuleWithSource y = + vcat + [ quotes (pretty (unWithSource y)) + , text "brought into scope by" + <+> dispModuleSource (getSource y) + ] diff --git a/src/Distribution/Backpack/MixLink.hs b/src/Distribution/Backpack/MixLink.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/MixLink.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +-- | See +module Distribution.Backpack.MixLink + ( mixLink + ) where + +import Distribution.Compat.Prelude hiding (mod) +import Prelude () + +import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.UnifyM + +import Distribution.ModuleName +import Distribution.Pretty +import Distribution.Types.ComponentId +import qualified Distribution.Utils.UnionFind as UnionFind + +import Control.Monad +import qualified Data.Foldable as F +import qualified Data.Map as Map +import Text.PrettyPrint + +----------------------------------------------------------------------- +-- Linking + +-- | Given to scopes of provisions and requirements, link them together. +mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) +mixLink scopes = do + let provs = Map.unionsWith (++) (map fst scopes) + -- Invariant: any identically named holes refer to same mutable cell + reqs = Map.unionsWith (++) (map snd scopes) + filled = Map.intersectionWithKey linkProvision provs reqs + F.sequenceA_ filled + let remaining = Map.difference reqs filled + return (provs, remaining) + +-- | Link a list of possibly provided modules to a single +-- requirement. This applies a side-condition that all +-- of the provided modules at the same name are *actually* +-- the same module. +linkProvision + :: ModuleName + -> [ModuleWithSourceU s] -- provs + -> [ModuleWithSourceU s] -- reqs + -> UnifyM s [ModuleWithSourceU s] +linkProvision mod_name ret@(prov : provs) (req : reqs) = do + -- TODO: coalesce all the non-unifying modules together + forM_ provs $ \prov' -> do + -- Careful: read it out BEFORE unifying, because the + -- unification algorithm preemptively unifies modules + mod <- convertModuleU (unWithSource prov) + mod' <- convertModuleU (unWithSource prov') + r <- unify prov prov' + case r of + Just () -> return () + Nothing -> do + addErr $ + text "Ambiguous module" + <+> quotes (pretty mod_name) + $$ text "It could refer to" + <+> ( text " " + <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) + $$ text "or" + <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) + ) + $$ link_doc + mod <- convertModuleU (unWithSource prov) + req_mod <- convertModuleU (unWithSource req) + self_cid <- fmap unify_self_cid getUnifEnv + case mod of + OpenModule (IndefFullUnitId cid _) _ + | cid == self_cid -> + addErr $ + text "Cannot instantiate requirement" + <+> quotes (pretty mod_name) + <+> in_scope_by (getSource req) + $$ text "with locally defined module" + <+> in_scope_by (getSource prov) + $$ text "as this would create a cyclic dependency, which GHC does not support." + $$ text "Try moving this module to a separate library, e.g.," + $$ text "create a new stanza: library 'sublib'." + _ -> return () + r <- unify prov req + case r of + Just () -> return () + Nothing -> do + -- TODO: Record and report WHERE the bad constraint came from + addErr $ + text "Could not instantiate requirement" + <+> quotes (pretty mod_name) + $$ nest + 4 + ( text "Expected:" + <+> pretty mod + $$ text "Actual: " + <+> pretty req_mod + ) + $$ parens + ( text "This can occur if an exposed module of" + <+> text "a libraries shares a name with another module." + ) + $$ link_doc + return ret + where + unify s1 s2 = + tryM $ + addErrContext short_link_doc $ + unifyModule (unWithSource s1) (unWithSource s2) + in_scope_by s = text "brought into scope by" <+> dispModuleSource s + short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name) + link_doc = text "While filling requirements of" <+> reqs_doc + reqs_doc + | null reqs = dispModuleSource (getSource req) + | otherwise = + ( text " " + <+> dispModuleSource (getSource req) + $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] + ) +linkProvision _ _ _ = error "linkProvision" + +----------------------------------------------------------------------- +-- The unification algorithm + +-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588 +-- which is a translation from Huet's thesis. + +unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () +unifyUnitId uid1_u uid2_u + | uid1_u == uid2_u = return () + | otherwise = do + xuid1 <- liftST $ UnionFind.find uid1_u + xuid2 <- liftST $ UnionFind.find uid2_u + case (xuid1, xuid2) of + (UnitIdThunkU u1, UnitIdThunkU u2) + | u1 == u2 -> return () + | otherwise -> + failWith $ + hang + (text "Couldn't match unit IDs:") + 4 + ( text " " + <+> pretty u1 + $$ text "and" + <+> pretty u2 + ) + (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) -> + unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u + (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) -> + unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u + (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) -> + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + +unifyThunkWith + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> DefUnitId + -> UnitIdU s + -> UnifyM s () +unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do + db <- fmap unify_db getUnifEnv + let FullUnitId cid2 insts2' = expandUnitId db uid2 + insts2 <- convertModuleSubst insts2' + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + +unifyInner + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> UnifyM s () +unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do + when (cid1 /= cid2) $ + -- TODO: if we had a package identifier, could be an + -- easier to understand error message. + failWith $ + hang + (text "Couldn't match component IDs:") + 4 + ( text " " + <+> pretty cid1 + $$ text "and" + <+> pretty cid2 + ) + -- The KEY STEP which makes this a Huet-style unification + -- algorithm. (Also a payoff of using union-find.) + -- We can build infinite unit IDs this way, which is necessary + -- for support mutual recursion. NB: union keeps the SECOND + -- descriptor, so we always arrange for a UnitIdThunkU to live + -- there. + liftST $ UnionFind.union uid1_u uid2_u + F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 + +-- | Imperatively unify two modules. +unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () +unifyModule mod1_u mod2_u + | mod1_u == mod2_u = return () + | otherwise = do + mod1 <- liftST $ UnionFind.find mod1_u + mod2 <- liftST $ UnionFind.find mod2_u + case (mod1, mod2) of + (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u + (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u + (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do + when (mod_name1 /= mod_name2) $ + failWith $ + hang (text "Cannot match module names") 4 $ + text " " + <+> pretty mod_name1 + $$ text "and" + <+> pretty mod_name2 + -- NB: this is not actually necessary (because we'll + -- detect loops eventually in 'unifyUnitId'), but it + -- seems harmless enough + liftST $ UnionFind.union mod1_u mod2_u + unifyUnitId uid1 uid2 diff --git a/src/Distribution/Backpack/ModSubst.hs b/src/Distribution/Backpack/ModSubst.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/ModSubst.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} + +-- | A type class 'ModSubst' for objects which can have 'ModuleSubst' +-- applied to them. +-- +-- See also +module Distribution.Backpack.ModSubst + ( ModSubst (..) + ) where + +import Distribution.Compat.Prelude hiding (mod) +import Prelude () + +import Distribution.Backpack +import Distribution.ModuleName + +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- | Applying module substitutions to semantic objects. +class ModSubst a where + -- In notation, substitution is postfix, which implies + -- putting it on the right hand side, but for partial + -- application it's more convenient to have it on the left + -- hand side. + modSubst :: OpenModuleSubst -> a -> a + +instance ModSubst OpenModule where + modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name + modSubst subst mod@(OpenModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod + +instance ModSubst OpenUnitId where + modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) + modSubst _subst uid = uid + +instance ModSubst (Set ModuleName) where + modSubst subst reqs = + Set.union + (Set.difference reqs (Map.keysSet subst)) + (openModuleSubstFreeHoles subst) + +-- Substitutions are functorial. NB: this means that +-- there is an @instance 'ModSubst' 'ModuleSubst'@! +instance ModSubst a => ModSubst (Map k a) where + modSubst subst = fmap (modSubst subst) +instance ModSubst a => ModSubst [a] where + modSubst subst = fmap (modSubst subst) +instance ModSubst a => ModSubst (k, a) where + modSubst subst (x, y) = (x, modSubst subst y) diff --git a/src/Distribution/Backpack/ModuleScope.hs b/src/Distribution/Backpack/ModuleScope.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/ModuleScope.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveTraversable #-} + +-- | See +module Distribution.Backpack.ModuleScope + ( -- * Module scopes + ModuleScope (..) + , ModuleProvides + , ModuleRequires + , ModuleSource (..) + , dispModuleSource + , WithSource (..) + , unWithSource + , getSource + , ModuleWithSource + , emptyModuleScope + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName +import Distribution.Pretty +import Distribution.Types.ComponentName +import Distribution.Types.IncludeRenaming +import Distribution.Types.LibraryName +import Distribution.Types.PackageName + +import Distribution.Backpack +import Distribution.Backpack.ModSubst + +import qualified Data.Map as Map +import Text.PrettyPrint + +----------------------------------------------------------------------- +-- Module scopes + +-- Why is ModuleProvides so complicated? The basic problem is that +-- we want to support this: +-- +-- package p where +-- include q (A) +-- include r (A) +-- module B where +-- import "q" A +-- import "r" A +-- +-- Specifically, in Cabal today it is NOT an error have two modules in +-- scope with the same identifier. So we need to preserve this for +-- Backpack. The modification is that an ambiguous module name is +-- OK... as long as it is NOT used to fill a requirement! +-- +-- So as a first try, we might try deferring unifying provisions that +-- are being glommed together, and check for equality after the fact. +-- But this doesn't work, because what if a multi-module provision +-- is used to fill a requirement?! So you do the equality test +-- IMMEDIATELY before a requirement fill happens... or never at all. +-- +-- Alternate strategy: go ahead and unify, and then if it is revealed +-- that some requirements got filled "out-of-thin-air", error. + +-- | A 'ModuleScope' describes the modules and requirements that +-- are in-scope as we are processing a Cabal package. Unlike +-- a 'ModuleShape', there may be multiple modules in scope at +-- the same 'ModuleName'; this is only an error if we attempt +-- to use those modules to fill a requirement. A 'ModuleScope' +-- can influence the 'ModuleShape' via a reexport. +data ModuleScope = ModuleScope + { modScopeProvides :: ModuleProvides + , modScopeRequires :: ModuleRequires + } + +-- | An empty 'ModuleScope'. +emptyModuleScope :: ModuleScope +emptyModuleScope = ModuleScope Map.empty Map.empty + +-- | Every 'Module' in scope at a 'ModuleName' is annotated with +-- the 'PackageName' it comes from. +type ModuleProvides = Map ModuleName [ModuleWithSource] + +-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m +type ModuleRequires = Map ModuleName [ModuleWithSource] + +-- TODO: consider newtping the two types above. + +-- | Description of where a module participating in mixin linking came +-- from. +data ModuleSource + = FromMixins PackageName ComponentName IncludeRenaming + | FromBuildDepends PackageName ComponentName + | FromExposedModules ModuleName + | FromOtherModules ModuleName + | FromSignatures ModuleName + +-- We don't have line numbers, but if we did, we'd want to record that +-- too + +-- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg +dispModuleSource :: ModuleSource -> Doc +dispModuleSource (FromMixins pn cn incls) = + text "mixins:" <+> dispComponent pn cn <+> pretty incls +dispModuleSource (FromBuildDepends pn cn) = + text "build-depends:" <+> dispComponent pn cn +dispModuleSource (FromExposedModules m) = + text "exposed-modules:" <+> pretty m +dispModuleSource (FromOtherModules m) = + text "other-modules:" <+> pretty m +dispModuleSource (FromSignatures m) = + text "signatures:" <+> pretty m + +-- Dependency +dispComponent :: PackageName -> ComponentName -> Doc +dispComponent pn cn = + -- NB: This syntax isn't quite the source syntax, but it + -- should be clear enough. To do source syntax, we'd + -- need to know what the package we're linking is. + case cn of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn + -- Case below shouldn't happen + _ -> pretty pn <+> parens (pretty cn) + +-- | An 'OpenModule', annotated with where it came from in a Cabal file. +data WithSource a = WithSource ModuleSource a + deriving (Functor, Foldable, Traversable) + +unWithSource :: WithSource a -> a +unWithSource (WithSource _ x) = x +getSource :: WithSource a -> ModuleSource +getSource (WithSource s _) = s +type ModuleWithSource = WithSource OpenModule + +instance ModSubst a => ModSubst (WithSource a) where + modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/src/Distribution/Backpack/ModuleShape.hs b/src/Distribution/Backpack/ModuleShape.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/ModuleShape.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | See +module Distribution.Backpack.ModuleShape + ( -- * Module shapes + ModuleShape (..) + , emptyModuleShape + , shapeInstalledPackage + ) where + +import Distribution.Compat.Prelude hiding (mod) +import Prelude () + +import Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName + +import Distribution.Backpack +import Distribution.Backpack.ModSubst + +import qualified Data.Map as Map +import qualified Data.Set as Set + +----------------------------------------------------------------------- +-- Module shapes + +-- | A 'ModuleShape' describes the provisions and requirements of +-- a library. We can extract a 'ModuleShape' from an +-- 'InstalledPackageInfo'. +data ModuleShape = ModuleShape + { modShapeProvides :: OpenModuleSubst + , modShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) + +instance Binary ModuleShape +instance Structured ModuleShape + +instance ModSubst ModuleShape where + modSubst subst (ModuleShape provs reqs) = + ModuleShape (modSubst subst provs) (modSubst subst reqs) + +-- | The default module shape, with no provisions and no requirements. +emptyModuleShape :: ModuleShape +emptyModuleShape = ModuleShape Map.empty Set.empty + +-- Food for thought: suppose we apply the Merkel tree optimization. +-- Imagine this situation: +-- +-- component p +-- signature H +-- module P +-- component h +-- module H +-- component a +-- signature P +-- module A +-- component q(P) +-- include p +-- include h +-- component r +-- include q (P) +-- include p (P) requires (H) +-- include h (H) +-- include a (A) requires (P) +-- +-- Component r should not have any conflicts, since after mix-in linking +-- the two P imports will end up being the same, so we can properly +-- instantiate it. But to know that q's P is p:P instantiated with h:H, +-- we have to be able to expand its unit id. Maybe we can expand it +-- lazily but in some cases it will need to be expanded. +-- +-- FWIW, the way that GHC handles this is by improving unit IDs as +-- soon as it sees an improved one in the package database. This +-- is a bit disgusting. +shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape +shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs + where + uid = installedOpenUnitId ipi + provs = map shapeExposedModule (IPI.exposedModules ipi) + reqs = requiredSignatures ipi + shapeExposedModule (IPI.ExposedModule mod_name Nothing) = + (mod_name, OpenModule uid mod_name) + shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) = + (mod_name, mod) diff --git a/src/Distribution/Backpack/PreExistingComponent.hs b/src/Distribution/Backpack/PreExistingComponent.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/PreExistingComponent.hs @@ -0,0 +1,79 @@ +-- | See +module Distribution.Backpack.PreExistingComponent + ( PreExistingComponent (..) + , ConfiguredPromisedComponent (..) + , ipiToPreExistingComponent + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.Backpack.ModuleShape +import Distribution.Package +import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageId + +import qualified Data.Map as Map +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Types.AnnotatedId + +-- | A /promised/ component. +-- +-- These components are promised to @configure@ but are not yet built. +-- +-- In other words this is 'PreExistingComponent' which doesn't yet exist. +data ConfiguredPromisedComponent = ConfiguredPromisedComponent + { pr_pkgname :: PackageName + , pr_cid :: AnnotatedId ComponentId + } + +instance Package ConfiguredPromisedComponent where + packageId = packageId . pr_cid + +-- | Stripped down version of 'LinkedComponent' for things +-- we don't need to know how to build. +data PreExistingComponent = PreExistingComponent + { pc_pkgname :: PackageName + -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid' + -- for internal dependencies: e.g., an internal component @lib@ may be + -- munged to @z-pkg-z-lib@, but we still want to use it when we see + -- @lib@ in @build-depends@ + , pc_compname :: ComponentName + -- ^ The actual name of the component. + , pc_munged_id :: MungedPackageId + , pc_uid :: UnitId + , pc_cid :: ComponentId + , pc_open_uid :: OpenUnitId + , pc_shape :: ModuleShape + } + +-- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', +-- which was brought into scope under the 'PackageName' (important for +-- a package qualified reference.) +ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent +ipiToPreExistingComponent ipi = + PreExistingComponent + { pc_pkgname = packageName ipi + , pc_compname = CLibName $ Installed.sourceLibName ipi + , pc_munged_id = mungedId ipi + , pc_uid = Installed.installedUnitId ipi + , pc_cid = Installed.installedComponentId ipi + , pc_open_uid = + IndefFullUnitId + (Installed.installedComponentId ipi) + (Map.fromList (Installed.instantiatedWith ipi)) + , pc_shape = shapeInstalledPackage ipi + } + +instance HasMungedPackageId PreExistingComponent where + mungedId = pc_munged_id + +instance Package PreExistingComponent where + packageId pec = PackageIdentifier (pc_pkgname pec) v + where + MungedPackageId _ v = pc_munged_id pec + +instance HasUnitId PreExistingComponent where + installedUnitId = pc_uid diff --git a/src/Distribution/Backpack/PreModuleShape.hs b/src/Distribution/Backpack/PreModuleShape.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/PreModuleShape.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Backpack.PreModuleShape + ( PreModuleShape (..) + , toPreModuleShape + , renamePreModuleShape + , mixLinkPreModuleShape + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Distribution.Backpack.ModuleShape +import Distribution.ModuleName +import Distribution.Types.IncludeRenaming +import Distribution.Types.ModuleRenaming + +data PreModuleShape = PreModuleShape + { preModShapeProvides :: Set ModuleName + , preModShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) + +toPreModuleShape :: ModuleShape -> PreModuleShape +toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs + +renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape +renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = + PreModuleShape + (Set.fromList (mapMaybe prov_fn (Set.toList provs))) + (Set.map req_fn reqs) + where + prov_fn = interpModuleRenaming prov_rn + req_fn k = fromMaybe k (interpModuleRenaming req_rn k) + +mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape +mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) + where + provs = Set.unions (map preModShapeProvides shapes) + reqs = Set.unions (map preModShapeRequires shapes) diff --git a/src/Distribution/Backpack/ReadyComponent.hs b/src/Distribution/Backpack/ReadyComponent.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/ReadyComponent.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | See +module Distribution.Backpack.ReadyComponent + ( ReadyComponent (..) + , InstantiatedComponent (..) + , IndefiniteComponent (..) + , rc_depends + , rc_uid + , rc_pkgid + , dispReadyComponent + , toReadyComponents + ) where + +import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () + +import Distribution.Backpack +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ModuleShape + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Types.AnnotatedId +import Distribution.Types.Component +import Distribution.Types.ComponentId +import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentName +import Distribution.Types.Library +import Distribution.Types.LibraryName +import Distribution.Types.Module +import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.PackageId +import Distribution.Types.PackageName.Magic +import Distribution.Types.UnitId + +import Distribution.ModuleName +import Distribution.Package +import Distribution.Simple.Utils + +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Text.PrettyPrint + +import Distribution.Pretty +import Distribution.Version + +-- | A 'ReadyComponent' is one that we can actually generate build +-- products for. We have a ready component for the typecheck-only +-- products of every indefinite package, as well as a ready component +-- for every way these packages can be fully instantiated. +data ReadyComponent = ReadyComponent + { rc_ann_id :: AnnotatedId UnitId + , rc_open_uid :: OpenUnitId + -- ^ The 'OpenUnitId' for this package. At the moment, this + -- is used in only one case, which is to determine if an + -- export is of a module from this library (indefinite + -- libraries record these exports as 'OpenModule'); + -- 'rc_open_uid' can be conveniently used to test for + -- equality, whereas 'UnitId' cannot always be used in this + -- case. + , rc_cid :: ComponentId + -- ^ Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' + -- records a 'ComponentId', it coincides with this one. + , rc_component :: Component + -- ^ Corresponds to 'lc_component'. + , rc_exe_deps :: [AnnotatedId UnitId] + -- ^ Corresponds to 'lc_exe_deps'. + -- Build-tools don't participate in mix-in linking. + -- (but what if they could?) + , rc_public :: Bool + -- ^ Corresponds to 'lc_public'. + , rc_i :: Either IndefiniteComponent InstantiatedComponent + -- ^ Extra metadata depending on whether or not this is an + -- indefinite library (typechecked only) or an instantiated + -- component (can be compiled). + } + +-- | The final, string 'UnitId' that will uniquely identify +-- the compilation products of this component. +rc_uid :: ReadyComponent -> UnitId +rc_uid = ann_id . rc_ann_id + +-- | Corresponds to 'lc_pkgid'. +rc_pkgid :: ReadyComponent -> PackageId +rc_pkgid = ann_pid . rc_ann_id + +-- | An 'InstantiatedComponent' is a library which is fully instantiated +-- (or, possibly, has no requirements at all.) +data InstantiatedComponent = InstantiatedComponent + { instc_insts :: [(ModuleName, Module)] + -- ^ How this library was instantiated. + , instc_insts_deps :: [(UnitId, MungedPackageId)] + -- ^ Dependencies induced by 'instc_insts'. These are recorded + -- here because there isn't a convenient way otherwise to get + -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. + , instc_provides :: Map ModuleName Module + -- ^ The modules exported/reexported by this library. + , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These always refer to installed + -- fully instantiated libraries. + } + +-- | An 'IndefiniteComponent' is a library with requirements +-- which we will typecheck only. +data IndefiniteComponent = IndefiniteComponent + { indefc_requires :: [ModuleName] + -- ^ The requirements of the library. + , indefc_provides :: Map ModuleName OpenModule + -- ^ The modules exported/reexported by this library. + , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These are 'OpenUnitId' because + -- these may refer to partially instantiated libraries. + } + +-- | Compute the dependencies of a 'ReadyComponent' that should +-- be recorded in the @depends@ field of 'InstalledPackageInfo'. +rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] +rc_depends rc = ordNub $ + case rc_i rc of + Left indefc -> + map + (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) + (indefc_includes indefc) + Right instc -> + map + (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) + (instc_includes instc) + ++ instc_insts_deps instc + where + toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId + toMungedPackageId ci = + computeCompatPackageId + (ci_pkgid ci) + ( case ci_cname ci of + CLibName name -> name + _ -> + error $ + prettyShow (rc_cid rc) + ++ " depends on non-library " + ++ prettyShow (ci_id ci) + ) + +-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is +-- a library. +rc_munged_id :: ReadyComponent -> MungedPackageId +rc_munged_id rc = + computeCompatPackageId + (rc_pkgid rc) + ( case rc_component rc of + CLib lib -> libName lib + _ -> error "rc_munged_id: not library" + ) + +instance Package ReadyComponent where + packageId = rc_pkgid + +instance HasUnitId ReadyComponent where + installedUnitId = rc_uid + +instance IsNode ReadyComponent where + type Key ReadyComponent = UnitId + nodeKey = rc_uid + nodeNeighbors rc = + ( case rc_i rc of + Right inst + | [] <- instc_insts inst -> + [] + | otherwise -> + [newSimpleUnitId (rc_cid rc)] + _ -> [] + ) + ++ ordNub (map fst (rc_depends rc)) + ++ map ann_id (rc_exe_deps rc) + +dispReadyComponent :: ReadyComponent -> Doc +dispReadyComponent rc = + hang + ( text + ( case rc_i rc of + Left _ -> "indefinite" + Right _ -> "definite" + ) + <+> pretty (nodeKey rc) + {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} + ) + 4 + $ vcat + [ text "depends" <+> pretty uid + | uid <- nodeNeighbors rc + ] + +-- | The state of 'InstM'; a mapping from 'UnitId's to their +-- ready component, or @Nothing@ if its an external +-- component which we don't know how to build. +type InstS = Map UnitId (Maybe ReadyComponent) + +-- | A state monad for doing instantiations (can't use actual +-- State because that would be an extra dependency.) +newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)} + +instance Functor InstM where + fmap f (InstM m) = InstM $ \s -> + let (x, s') = m s + in (f x, s') + +instance Applicative InstM where + pure a = InstM $ \s -> (a, s) + InstM f <*> InstM x = InstM $ \s -> + let (f', s') = f s + (x', s'') = x s' + in (f' x', s'') + +instance Monad InstM where + return = pure + InstM m >>= f = InstM $ \s -> + let (x, s') = m s + in runInstM (f x) s' + +-- | Given a list of 'LinkedComponent's, expand the module graph +-- so that we have an instantiated graph containing all of the +-- instantiated components we need to build. +-- +-- Instantiation intuitively follows the following algorithm: +-- +-- instantiate a definite unit id p[S]: +-- recursively instantiate each module M in S +-- recursively instantiate modules exported by this unit +-- recursively instantiate dependencies substituted by S +-- +-- The implementation is a bit more involved to memoize instantiation +-- if we have done it already. +-- +-- We also call 'improveUnitId' during this process, so that fully +-- instantiated components are given 'HashedUnitId'. +toReadyComponents + :: Map UnitId MungedPackageId + -> Map ModuleName Module -- subst for the public component + -> [LinkedComponent] + -> [ReadyComponent] +toReadyComponents pid_map subst0 comps = + catMaybes (Map.elems ready_map) + where + cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps] + + instantiateUnitId + :: ComponentId + -> Map ModuleName Module + -> InstM DefUnitId + instantiateUnitId cid insts = InstM $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = + runInstM + (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) + where + -- The mkDefUnitId here indicates that we assume + -- that Cabal handles unit id hash allocation. + -- Good thing about hashing here: map is only on string. + -- Bad thing: have to repeatedly hash. + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid + + instantiateComponent + :: UnitId + -> ComponentId + -> Map ModuleName Module + -> InstM (Maybe ReadyComponent) + instantiateComponent uid cid insts + | Just lc <- Map.lookup cid cmap = do + provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) + -- NB: lc_sig_includes is omitted here, because we don't + -- need them to build + includes <- forM (lc_includes lc) $ \ci -> do + uid' <- substUnitId insts (ci_id ci) + return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)} + exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) + s <- InstM $ \s -> (s, s) + let getDep (Module dep_def_uid _) + | let dep_uid = unDefUnitId dep_def_uid = + -- Lose DefUnitId invariant for rc_depends + [ + ( dep_uid + , fromMaybe err_pid $ + Map.lookup dep_uid pid_map + <|> fmap rc_munged_id (join (Map.lookup dep_uid s)) + ) + ] + where + err_pid = + MungedPackageId + (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) + (mkVersion [0]) + instc = + InstantiatedComponent + { instc_insts = Map.toList insts + , instc_insts_deps = concatMap getDep (Map.elems insts) + , instc_provides = provides + , instc_includes = includes + -- NB: there is no dependency on the + -- indefinite version of this instantiated package here, + -- as (1) it doesn't go in depends in the + -- IPI: it's not a run time dep, and (2) + -- we don't have to tell GHC about it, it + -- will match up the ComponentId + -- automatically + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid) + , rc_cid = lc_cid lc + , rc_component = lc_component lc + , rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Right instc + } + | otherwise = return Nothing + + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId _ (DefiniteUnitId uid) = + return uid + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst + :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) + substSubst subst insts = traverse (substModule subst) insts + + substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + uid' <- substUnitId subst uid + return (Module uid' mod_name) + + substExeDep + :: Map ModuleName Module + -> AnnotatedId OpenUnitId + -> InstM (AnnotatedId UnitId) + substExeDep insts exe_aid = do + exe_uid' <- substUnitId insts (ann_id exe_aid) + return exe_aid{ann_id = unDefUnitId exe_uid'} + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + InstM $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) + indefiniteComponent uid cid + | Just lc <- Map.lookup cid cmap = do + -- We're going to process includes, in case some of them + -- are fully definite even without any substitution. We + -- want to build those too; see #5634. + inst_includes <- forM (lc_includes lc) $ \ci -> + if Set.null (openUnitIdFreeHoles (ci_id ci)) + then do + uid' <- substUnitId Map.empty (ci_id ci) + return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)} + else return ci + exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) + let indefc = + IndefiniteComponent + { indefc_requires = map fst (lc_insts lc) + , indefc_provides = modShapeProvides (lc_shape lc) + , indefc_includes = inst_includes ++ lc_sig_includes lc + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_cid = lc_cid lc + , rc_open_uid = lc_uid lc + , rc_component = lc_component lc + , -- It's always fully built + rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Left indefc + } + | otherwise = return Nothing + + ready_map = snd $ runInstM work Map.empty + + work + -- Top-level instantiation per subst0 + | not (Map.null subst0) + , [lc] <- filter lc_public (Map.elems cmap) = + do + _ <- instantiateUnitId (lc_cid lc) subst0 + return () + | otherwise = + forM_ (Map.elems cmap) $ \lc -> + if null (lc_insts lc) + then instantiateUnitId (lc_cid lc) Map.empty >> return () + else indefiniteUnitId (lc_cid lc) >> return () diff --git a/src/Distribution/Backpack/UnifyM.hs b/src/Distribution/Backpack/UnifyM.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Backpack/UnifyM.hs @@ -0,0 +1,676 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 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 + +import Distribution.Compat.Prelude hiding (mod) +import Prelude () + +import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModSubst +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModuleShape + +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import qualified Distribution.Utils.UnionFind as UnionFind +import Distribution.Verbosity + +import Control.Monad.ST +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.STRef +import qualified Data.Set as Set +import Data.Traversable +import Text.PrettyPrint + +-- TODO: more detailed trace output on high verbosity would probably +-- be appreciated by users debugging unification errors. Collect +-- some good examples! + +data ErrMsg = ErrMsg + { err_msg :: Doc + , err_ctx :: [Doc] + } +type MsgDoc = Doc + +renderErrMsg :: ErrMsg -> MsgDoc +renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} = + msg $$ vcat ctx + +-- | The unification monad, this monad encapsulates imperative +-- unification. +newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)} + +-- | Run a computation in the unification monad. +runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a +runUnifyM verbosity self_cid db m = + runST $ do + i <- newSTRef 0 + hmap <- newSTRef Map.empty + errs <- newSTRef [] + mb_r <- + unUnifyM + m + UnifEnv + { unify_uniq = i + , unify_reqs = hmap + , unify_self_cid = self_cid + , unify_verbosity = verbosity + , unify_ctx = [] + , unify_db = db + , unify_errs = errs + } + final_errs <- readSTRef errs + case mb_r of + Just x | null final_errs -> return (Right x) + _ -> return (Left (map renderErrMsg (reverse final_errs))) + +-- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. + +type ErrCtx s = MsgDoc + +-- | The unification environment. +data UnifEnv s = UnifEnv + { unify_uniq :: UnifRef s UnitIdUnique + -- ^ A supply of unique integers to label 'UnitIdU' + -- cells. This is used to determine loops in unit + -- identifiers (which can happen with mutual recursion.) + , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)) + -- ^ The set of requirements in scope. When + -- a provision is brought into scope, we unify with + -- the requirement at the same module name to fill it. + -- This mapping grows monotonically. + , unify_self_cid :: ComponentId + -- ^ Component id of the unit we're linking. We use this + -- to detect if we fill a requirement with a local module, + -- which in principle should be OK but is not currently + -- supported by GHC. + , unify_verbosity :: Verbosity + -- ^ How verbose the error message should be + , unify_ctx :: [ErrCtx s] + -- ^ The error reporting context + , unify_db :: FullDb + -- ^ The package index for expanding unit identifiers + , unify_errs :: UnifRef s [ErrMsg] + -- ^ Accumulated errors + } + +instance Functor (UnifyM s) where + fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) + +instance Applicative (UnifyM s) where + pure = UnifyM . pure . pure . pure + UnifyM f <*> UnifyM x = UnifyM $ \r -> do + f' <- f r + case f' of + Nothing -> return Nothing + Just f'' -> do + x' <- x r + case x' of + Nothing -> return Nothing + Just x'' -> return (Just (f'' x'')) + +instance Monad (UnifyM s) where + return = pure + UnifyM m >>= f = UnifyM $ \r -> do + x <- m r + case x of + Nothing -> return Nothing + Just x' -> unUnifyM (f x') r + +-- | Lift a computation from 'ST' monad to 'UnifyM' monad. +-- Internal use only. +liftST :: ST s a -> UnifyM s a +liftST m = UnifyM $ \_ -> fmap Just m + +addErr :: MsgDoc -> UnifyM s () +addErr msg = do + env <- getUnifEnv + let err = + ErrMsg + { err_msg = msg + , err_ctx = unify_ctx env + } + liftST $ modifySTRef (unify_errs env) (\errs -> err : errs) + +failWith :: MsgDoc -> UnifyM s a +failWith msg = do + addErr msg + failM + +failM :: UnifyM s a +failM = UnifyM $ \_ -> return Nothing + +failIfErrs :: UnifyM s () +failIfErrs = do + env <- getUnifEnv + errs <- liftST $ readSTRef (unify_errs env) + when (not (null errs)) failM + +tryM :: UnifyM s a -> UnifyM s (Maybe a) +tryM m = + UnifyM + ( \env -> do + mb_r <- unUnifyM m env + return (Just mb_r) + ) + +{- +otherFail :: ErrMsg -> UnifyM s a +otherFail s = UnifyM $ \_ -> return (Left s) + +unifyFail :: ErrMsg -> UnifyM s a +unifyFail err = do + env <- getUnifEnv + msg <- case unify_ctx env of + Nothing -> return (text "Unspecified unification error:" <+> err) + Just (ctx, mod1, mod2) + | unify_verbosity env > normal + -> do mod1' <- convertModuleU mod1 + mod2' <- convertModuleU mod2 + let extra = " (was unifying " ++ display mod1' + ++ " and " ++ display mod2' ++ ")" + return (ctx ++ err ++ extra) + | otherwise + -> return (ctx ++ err ++ " (for more information, pass -v flag)") + UnifyM $ \_ -> return (Left msg) +-} + +-- | A convenient alias for mutable references in the unification monad. +type UnifRef s a = STRef s a + +-- | Imperatively read a 'UnifRef'. +readUnifRef :: UnifRef s a -> UnifyM s a +readUnifRef = liftST . readSTRef + +-- | Imperatively write a 'UnifRef'. +writeUnifRef :: UnifRef s a -> a -> UnifyM s () +writeUnifRef x = liftST . writeSTRef x + +-- | Get the current unification environment. +getUnifEnv :: UnifyM s (UnifEnv s) +getUnifEnv = UnifyM $ \r -> return (return r) + +-- | Add a fixed message to the error context. +addErrContext :: Doc -> UnifyM s a -> UnifyM s a +addErrContext ctx m = addErrContextM ctx m + +-- | Add a message to the error context. It may make monadic queries. +addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a +addErrContextM ctx m = + UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r} + +----------------------------------------------------------------------- +-- The "unifiable" variants of the data types +-- +-- In order to properly do unification over infinite trees, we +-- need to union find over 'Module's and 'UnitId's. The pure +-- representation is ill-equipped to do this, so we convert +-- from the pure representation into one which is indirected +-- through union-find. 'ModuleU' handles hole variables; +-- 'UnitIdU' handles mu-binders. + +-- | Contents of a mutable 'ModuleU' reference. +data ModuleU' s + = ModuleU (UnitIdU s) ModuleName + | ModuleVarU ModuleName + +-- | Contents of a mutable 'UnitIdU' reference. +data UnitIdU' s + = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) + | UnitIdThunkU DefUnitId + +-- | A mutable version of 'Module' which can be imperatively unified. +type ModuleU s = UnionFind.Point s (ModuleU' s) + +-- | A mutable version of 'UnitId' which can be imperatively unified. +type UnitIdU s = UnionFind.Point s (UnitIdU' s) + +-- | An integer for uniquely labeling 'UnitIdU' nodes. We need +-- these labels in order to efficiently serialize 'UnitIdU's into +-- 'UnitId's (we use the label to check if any parent is the +-- node in question, and if so insert a deBruijn index instead.) +-- These labels must be unique across all 'UnitId's/'Module's which +-- participate in unification! +type UnitIdUnique = Int + +----------------------------------------------------------------------- +-- Conversion to the unifiable data types + +-- An environment for tracking the mu-bindings in scope. +-- The invariant for a state @(m, i)@ is that [0..i] are +-- keys of @m@; in fact, the @i-k@th entry is the @k@th +-- de Bruijn index (this saves us from having to shift as +-- we enter mu-binders.) +type MuEnv s = (IntMap (UnitIdU s), Int) + +extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s +extendMuEnv (m, i) x = + (IntMap.insert (i + 1) x m, i + 1) + +{- +lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s +lookupMuEnv (m, i) k = + case IntMap.lookup (i - k) m of + -- Technically a user can trigger this by giving us a + -- bad 'UnitId', so handle this better. + Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)" + Just v -> v +-} + +emptyMuEnv :: MuEnv s +emptyMuEnv = (IntMap.empty, -1) + +-- The workhorse functions. These share an environment: +-- * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes +-- * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized) +-- environment containing the implicitly universally quantified +-- @hole:A@ binders. +-- * @MuEnv@ - the environment for mu-binders. + +convertUnitId' + :: MuEnv s + -> OpenUnitId + -> UnifyM s (UnitIdU s) +-- TODO: this could be more lazy if we know there are no internal +-- references +convertUnitId' _ (DefiniteUnitId uid) = + liftST $ UnionFind.fresh (UnitIdThunkU uid) +convertUnitId' stk (IndefFullUnitId cid insts) = do + fs <- fmap unify_uniq getUnifEnv + x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later + insts_u <- for insts $ convertModule' (extendMuEnv stk x) + u <- readUnifRef fs + writeUnifRef fs (u + 1) + y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) + liftST $ UnionFind.union x y + return y + +-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) + +convertModule' + :: MuEnv s + -> OpenModule + -> UnifyM s (ModuleU s) +convertModule' _stk (OpenModuleVar mod_name) = do + hmap <- fmap unify_reqs getUnifEnv + hm <- readUnifRef hmap + case Map.lookup mod_name hm of + Nothing -> do + mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) + writeUnifRef hmap (Map.insert mod_name mod hm) + return mod + Just mod -> return mod +convertModule' stk (OpenModule uid mod_name) = do + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + +convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) +convertUnitId = convertUnitId' emptyMuEnv + +convertModule :: OpenModule -> UnifyM s (ModuleU s) +convertModule = convertModule' emptyMuEnv + +----------------------------------------------------------------------- +-- Substitutions + +-- | The mutable counterpart of a 'ModuleSubst' (not defined here). +type ModuleSubstU s = Map ModuleName (ModuleU s) + +-- | Conversion of 'ModuleSubst' to 'ModuleSubstU' +convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s)) +convertModuleSubst = traverse convertModule + +-- | Conversion of 'ModuleSubstU' to 'ModuleSubst' +convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst +convertModuleSubstU = traverse convertModuleU + +----------------------------------------------------------------------- +-- Conversion from the unifiable data types + +-- An environment for tracking candidates for adding a mu-binding. +-- The invariant for a state @(m, i)@, is that if we encounter a node +-- labeled @k@ such that @m[k -> v]@, then we can replace this +-- node with the de Bruijn index @i-v@ referring to an enclosing +-- mu-binder; furthermore, @range(m) = [0..i]@. +type MooEnv = (IntMap Int, Int) + +emptyMooEnv :: MooEnv +emptyMooEnv = (IntMap.empty, -1) + +extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv +extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1) + +lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int +lookupMooEnv (m, i) k = + case IntMap.lookup k m of + Nothing -> Nothing + Just v -> Just (i - v) -- de Bruijn indexize + +-- The workhorse functions + +-- | Returns `OpenUnitId` if there is no a mutually recursive unit. +-- | Otherwise returns a list of signatures instantiated by given `UnitIdU`. +convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId +convertUnitIdU' stk uid_u required_mod_name = do + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return $ DefiniteUnitId uid + UnitIdU u cid insts_u -> + case lookupMooEnv stk u of + Just _ -> + let mod_names = Map.keys insts_u + in failWithMutuallyRecursiveUnitsError required_mod_name mod_names + Nothing -> do + insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) + return $ IndefFullUnitId cid insts + +convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule +convertModuleU' stk mod_u = do + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (OpenModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u (pretty mod_name) + return (OpenModule uid mod_name) + +failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a +failWithMutuallyRecursiveUnitsError required_mod_name mod_names = + let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names + in failWith $ + text "Cannot instantiate requirement" + <+> quotes required_mod_name + $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:" + <+> sigsList + $$ text "as this creates a cyclic dependency, which GHC does not support." + +-- Helper functions + +convertUnitIdU :: UnitIdU s -> Doc -> UnifyM s OpenUnitId +convertUnitIdU = convertUnitIdU' emptyMooEnv + +convertModuleU :: ModuleU s -> UnifyM s OpenModule +convertModuleU = convertModuleU' emptyMooEnv + +-- | An empty 'ModuleScopeU'. +emptyModuleScopeU :: ModuleScopeU s +emptyModuleScopeU = (Map.empty, Map.empty) + +-- | The mutable counterpart of 'ModuleScope'. +type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) + +-- | The mutable counterpart of 'ModuleProvides' +type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] + +type ModuleRequiresU s = ModuleProvidesU s +type ModuleWithSourceU s = WithSource (ModuleU s) + +-- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource +ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc +ci_msg ci + | ci_implicit ci = text "build-depends:" <+> pp_pn + | otherwise = text "mixins:" <+> pp_pn <+> pretty (ci_renaming ci) + where + pn = pkgName (ci_pkgid ci) + pp_pn = + case ci_cname ci of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn + -- Shouldn't happen + cn -> pretty pn <+> parens (pretty cn) + +-- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do +-- unification on it. +convertInclude + :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming + -> UnifyM + s + ( ModuleScopeU s + , Either + (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -}) + (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -}) + ) +convertInclude + ci@( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = (uid, ModuleShape provs reqs) + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = incl@(IncludeRenaming prov_rns req_rns) + , ci_implicit = implicit + } + ) = addErrContext (text "In" <+> ci_msg ci) $ do + let pn = packageName pid + the_source + | implicit = + FromBuildDepends pn compname + | otherwise = + FromMixins pn compname incl + source = WithSource the_source + + -- Suppose our package has two requirements A and B, and + -- we include it with @requires (A as X)@ + -- There are three closely related things we compute based + -- off of @reqs@ and @reqs_rns@: + -- + -- 1. The requirement renaming (A -> X) + -- 2. The requirement substitution (A -> , B -> ) + + -- Requirement renaming. This is read straight off the syntax: + -- + -- [nothing] ==> [empty] + -- requires (B as Y) ==> B -> Y + -- + -- Requirement renamings are NOT injective: if two requirements + -- are mapped to the same name, the intent is to merge them + -- together. But they are *functions*, so @B as X, B as Y@ is + -- illegal. + + req_rename_list <- + case req_rns of + DefaultRenaming -> return [] + HidingRenaming _ -> do + -- Not valid here for requires! + addErr $ + text "Unsupported syntax" + <+> quotes (text "requires hiding (...)") + return [] + ModuleRenaming rns -> return rns + + let req_rename_listmap :: Map ModuleName [ModuleName] + req_rename_listmap = + Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list] + req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> + case vs0 of + [] -> error "req_rename" + [v] -> return v + v : vs -> do + addErr $ + text "Conflicting renamings of requirement" + <+> quotes (pretty k) + $$ text "Renamed to: " + <+> vcat (map pretty (v : vs)) + return v + + let req_rename_fn k = case Map.lookup k req_rename of + Nothing -> k + Just v -> v + + -- Requirement substitution. + -- + -- A -> X ==> A -> + let req_subst = fmap OpenModuleVar req_rename + + uid_u <- convertUnitId (modSubst req_subst uid) + + -- Requirement mapping. This is just taking the range of the + -- requirement substitution, and making a mapping so that it is + -- convenient to merge things together. It INCLUDES the implicit + -- mappings. + -- + -- A -> X ==> X -> , B -> + reqs_u <- + convertModuleRequires . Map.fromList $ + [ (k, [source (OpenModuleVar k)]) + | k <- map req_rename_fn (Set.toList reqs) + ] + + -- Report errors if there were unused renamings + let leftover = Map.keysSet req_rename `Set.difference` reqs + unless (Set.null leftover) $ + addErr $ + hang + ( text "The" + <+> text (showComponentName compname) + <+> text "from package" + <+> quotes (pretty pid) + <+> text "does not require:" + ) + 4 + (vcat (map pretty (Set.toList leftover))) + + -- Provision computation is more complex. + -- For example, if we have: + -- + -- include p (A as X) requires (B as Y) + -- where A -> q[B=]:A + -- + -- Then we need: + -- + -- X -> [("p", q[B=]:A)] + -- + -- There are a bunch of clever ways to present the algorithm + -- but here is the simple one: + -- + -- 1. If we have a default renaming, apply req_subst + -- to provs and use that. + -- + -- 2. Otherwise, build a map by successively looking + -- up the referenced modules in the renaming in provs. + -- + -- Importantly, overlapping rename targets get accumulated + -- together. It's not an (immediate) error. + (pre_prov_scope, prov_rns') <- + case prov_rns of + DefaultRenaming -> return (Map.toList provs, prov_rns) + HidingRenaming hides -> + let hides_set = Set.fromList hides + in let r = + [ (k, v) + | (k, v) <- Map.toList provs + , not (k `Set.member` hides_set) + ] + in -- GHC doesn't understand hiding, so expand it out! + return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r)) + ModuleRenaming rns -> do + r <- + sequence + [ case Map.lookup from provs of + Just m -> return (to, m) + Nothing -> + failWith $ + text "Package" + <+> quotes (pretty pid) + <+> text "does not expose the module" + <+> quotes (pretty from) + | (from, to) <- rns + ] + return (r, prov_rns) + let prov_scope = + modSubst req_subst $ + Map.fromListWith + (++) + [ (k, [source v]) + | (k, v) <- pre_prov_scope + ] + + provs_u <- convertModuleProvides prov_scope + + -- TODO: Assert that provs_u is empty if provs was empty + return + ( (provs_u, reqs_u) + , -- NB: We test that requirements is not null so that + -- users can create packages with zero module exports + -- that cause some C library to linked in, etc. + ( if Map.null provs && not (Set.null reqs) + then Right -- is sig + else Left + ) + ( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = uid_u + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = prov_rns' + , ci_implicit = ci_implicit ci + } + ) + ) + +-- | Convert a 'ModuleScopeU' to a 'ModuleScope'. +convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope +convertModuleScopeU (provs_u, reqs_u) = do + provs <- convertModuleProvidesU provs_u + reqs <- convertModuleRequiresU reqs_u + -- TODO: Test that the requirements are still free. If they + -- are not, they got unified, and that's dodgy at best. + return (ModuleScope provs reqs) + +-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' +convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) +convertModuleProvides = traverse (traverse (traverse convertModule)) + +-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides' +convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides +convertModuleProvidesU = traverse (traverse (traverse convertModuleU)) + +convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s) +convertModuleRequires = convertModuleProvides + +convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires +convertModuleRequiresU = convertModuleProvidesU diff --git a/src/Distribution/Compat/Async.hs b/src/Distribution/Compat/Async.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Async.hs @@ -0,0 +1,155 @@ +-- | 'Async', yet using 'MVar's. +-- +-- Adopted from @async@ library +-- Copyright (c) 2012, Simon Marlow +-- Licensed under BSD-3-Clause +-- +-- @since 3.2.0.0 +module Distribution.Compat.Async + ( AsyncM + , withAsync + , waitCatch + , wait + , asyncThreadId + , cancel + , uninterruptibleCancel + , AsyncCancelled (..) + + -- * Cabal extras + , withAsyncNF + ) where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.DeepSeq (NFData, force) +import Control.Exception + ( BlockedIndefinitelyOnMVar (..) + , Exception (..) + , SomeException (..) + , asyncExceptionFromException + , asyncExceptionToException + , catch + , evaluate + , mask + , throwIO + , throwTo + , try + , uninterruptibleMask_ + ) +import Control.Monad (void) +import GHC.Exts (inline) + +-- | Async, but based on 'MVar', as we don't depend on @stm@. +data AsyncM a = Async + { asyncThreadId :: {-# UNPACK #-} !ThreadId + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) + } + +-- | Spawn an asynchronous action in a separate thread, and pass its +-- @Async@ handle to the supplied function. When the function returns +-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. +-- +-- > withAsync action inner = mask $ \restore -> do +-- > a <- async (restore action) +-- > restore (inner a) `finally` uninterruptibleCancel a +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Note: a reference to the child thread is kept alive until the call +-- to `withAsync` returns, so nesting many `withAsync` calls requires +-- linear memory. +withAsync :: IO a -> (AsyncM a -> IO b) -> IO b +withAsync = inline withAsyncUsing forkIO + +withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) + where + evaluateNF = evaluate . force + +withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsyncUsing doFork = \action inner -> do + var <- newEmptyMVar + mask $ \restore -> do + t <- doFork $ try (restore action) >>= putMVar var + let a = Async t var + r <- + restore (inner a) `catchAll` \e -> do + uninterruptibleCancel a + throwIO e + uninterruptibleCancel a + return r + +-- | Wait for an asynchronous action to complete, and return its +-- value. If the asynchronous action threw an exception, then the +-- exception is re-thrown by 'wait'. +-- +-- > wait = atomically . waitSTM +{-# INLINE wait #-} +wait :: AsyncM a -> IO a +wait a = do + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x + +-- | Wait for an asynchronous action to complete, and return either +-- @Left e@ if the action raised an exception @e@, or @Right a@ if it +-- returned a value @a@. +-- +-- > waitCatch = atomically . waitCatchSTM +{-# INLINE waitCatch #-} +waitCatch :: AsyncM a -> IO (Either SomeException a) +waitCatch (Async _ var) = tryAgain (readMVar var) + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f + +catchAll :: IO a -> (SomeException -> IO a) -> IO a +catchAll = catch + +-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ +-- exception to it, and waiting for the `Async` thread to quit. +-- Has no effect if the 'Async' has already completed. +-- +-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a +-- +-- Note that 'cancel' will not terminate until the thread the 'Async' +-- refers to has terminated. This means that 'cancel' will block for +-- as long said thread blocks when receiving an asynchronous exception. +-- +-- For example, it could block if: +-- +-- * It's executing a foreign call, and thus cannot receive the asynchronous +-- exception; +-- * It's executing some cleanup handler after having received the exception, +-- and the handler is blocking. +{-# INLINE cancel #-} +cancel :: AsyncM a -> IO () +cancel a@(Async t _) = do + throwTo t AsyncCancelled + void (waitCatch a) + +-- | The exception thrown by `cancel` to terminate a thread. +data AsyncCancelled = AsyncCancelled + deriving + ( Show + , Eq + ) + +instance Exception AsyncCancelled where + -- wraps in SomeAsyncException + -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 + fromException = asyncExceptionFromException + toException = asyncExceptionToException + +-- | Cancel an asynchronous action +-- +-- This is a variant of `cancel`, but it is not interruptible. +{-# INLINE uninterruptibleCancel #-} +uninterruptibleCancel :: AsyncM a -> IO () +uninterruptibleCancel = uninterruptibleMask_ . cancel diff --git a/src/Distribution/Compat/CopyFile.hs b/src/Distribution/Compat/CopyFile.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/CopyFile.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} + +module Distribution.Compat.CopyFile + ( copyFile + , copyFileChanged + , filesEqual + , copyOrdinaryFile + , copyExecutableFile + , setFileOrdinary + , setFileExecutable + , setDirOrdinary + ) where + +import Distribution.Compat.Prelude +import Prelude () + +#ifndef mingw32_HOST_OS +import Distribution.Compat.Internal.TempFile + +import Control.Exception + ( bracketOnError ) +import qualified Data.ByteString.Lazy as BSL +import Data.Bits + ( (.|.) ) +import System.IO.Error + ( ioeSetLocation ) +import System.Directory + ( doesFileExist, renameFile, removeFile ) +import System.FilePath + ( takeDirectory ) +import System.IO + ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize + , withBinaryFile ) +import Foreign + ( allocaBytes ) + +import System.Posix.Types + ( FileMode ) +import System.Posix.Files + ( getFileStatus, fileMode, setFileMode ) + +#else /* else mingw32_HOST_OS */ + +import qualified Data.ByteString.Lazy as BSL +import System.IO.Error + ( ioeSetLocation ) +import System.Directory + ( doesFileExist ) +import System.FilePath + ( addTrailingPathSeparator + , hasTrailingPathSeparator + , isPathSeparator + , isRelative + , joinDrive + , joinPath + , pathSeparator + , pathSeparators + , splitDirectories + , splitDrive + ) +import System.IO + ( IOMode(ReadMode), hFileSize + , withBinaryFile ) + +import qualified System.Win32.File as Win32 ( copyFile ) +#endif /* mingw32_HOST_OS */ + +copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest + +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +#ifndef mingw32_HOST_OS +-- When running with a restrictive UMASK such as 0077 we still want to +-- install files and directories that are accessible to other users. +setFileOrdinary path = addFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x + +addFileMode :: FilePath -> FileMode -> IO () +addFileMode name m = do + o <- fileMode <$> getFileStatus name + setFileMode name (m .|. o) +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable + +-- | Copies a file to a new destination. +-- Often you should use `copyFileChanged` instead. +copyFile :: FilePath -> FilePath -> IO () +copyFile fromFPath toFPath = + copy + `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) + where +#ifndef mingw32_HOST_OS + copy = withBinaryFile fromFPath ReadMode $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do + hClose hTmp `catchIO` \_ -> return () + removeFile tmpFPath `catchIO` \_ -> return () + bufferSize = 4096 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer +#else + copy = Win32.copyFile (toExtendedLengthPath fromFPath) + (toExtendedLengthPath toFPath) + False + +-- NOTE: Shamelessly lifted from System.Directory.Internal.Windows + +-- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains +-- unchanged if the prefix is not added. This function can sometimes be used +-- to bypass the @MAX_PATH@ length restriction in Windows API calls. +-- +-- See Note [Path normalization]. +toExtendedLengthPath :: FilePath -> FilePath +toExtendedLengthPath path + | isRelative path = path + | otherwise = + case normalisedPath of + '\\' : '?' : '?' : '\\' : _ -> normalisedPath + '\\' : '\\' : '?' : '\\' : _ -> normalisedPath + '\\' : '\\' : '.' : '\\' : _ -> normalisedPath + '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath + _ -> "\\\\?\\" <> normalisedPath + where normalisedPath = simplifyWindows path + +-- | Similar to 'normalise' but: +-- +-- * empty paths stay empty, +-- * parent dirs (@..@) are expanded, and +-- * paths starting with @\\\\?\\@ are preserved. +-- +-- The goal is to preserve the meaning of paths better than 'normalise'. +-- +-- Note [Path normalization] +-- 'normalise' doesn't simplify path names but will convert / into \\ +-- this would normally not be a problem as once the path hits the RTS we would +-- have simplified the path then. However since we're calling the WIn32 API +-- directly we have to do the simplification before the call. Without this the +-- path Z:// would become Z:\\\\ and when converted to a device path the path +-- becomes \\?\Z:\\\\ which is an invalid path. +-- +-- This is not a bug in normalise as it explicitly states that it won't simplify +-- a FilePath. +simplifyWindows :: FilePath -> FilePath +simplifyWindows "" = "" +simplifyWindows path = + case drive' of + "\\\\?\\" -> drive' <> subpath + _ -> simplifiedPath + where + simplifiedPath = joinDrive drive' subpath' + (drive, subpath) = splitDrive path + drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) + subpath' = appendSep . avoidEmpty . prependSep . joinPath . + stripPardirs . expandDots . skipSeps . + splitDirectories $ subpath + + upperDrive d = case d of + c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s + _ -> d + skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) + stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") + | otherwise = id + prependSep | subpathIsAbsolute = (pathSeparator :) + | otherwise = id + avoidEmpty | not pathIsAbsolute + && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." + = emptyToCurDir + | otherwise = id + appendSep p | hasTrailingPathSep + && not (pathIsAbsolute && null p) + = addTrailingPathSeparator p + | otherwise = p + pathIsAbsolute = not (isRelative path) + subpathIsAbsolute = any isPathSeparator (take 1 subpath) + hasTrailingPathSep = hasTrailingPathSeparator subpath + +-- | Given a list of path segments, expand @.@ and @..@. The path segments +-- must not contain path separators. +expandDots :: [FilePath] -> [FilePath] +expandDots = reverse . go [] + where + go ys' xs' = + case xs' of + [] -> ys' + x : xs -> + case x of + "." -> go ys' xs + ".." -> + case ys' of + [] -> go (x : ys') xs + ".." : _ -> go (x : ys') xs + _ : ys -> go ys xs + _ -> go (x : ys') xs + +-- | Convert to the right kind of slashes. +normalisePathSeps :: FilePath -> FilePath +normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p + +-- | Remove redundant trailing slashes and pick the right kind of slash. +normaliseTrailingSep :: FilePath -> FilePath +normaliseTrailingSep path = do + let path' = reverse path + let (sep, path'') = span isPathSeparator path' + let addSep = if null sep then id else (pathSeparator :) + reverse (addSep path'') + +-- | Convert empty paths to the current directory, otherwise leave it +-- unchanged. +emptyToCurDir :: FilePath -> FilePath +emptyToCurDir "" = "." +emptyToCurDir path = path +#endif /* mingw32_HOST_OS */ + +-- | Like `copyFile`, but does not touch the target if source and destination +-- are already byte-identical. This is recommended as it is useful for +-- time-stamp based recompilation avoidance. +copyFileChanged :: FilePath -> FilePath -> IO () +copyFileChanged src dest = do + equal <- filesEqual src dest + unless equal $ copyFile src dest + +-- | Checks if two files are byte-identical. +-- Returns False if either of the files do not exist or if files +-- are of different size. +filesEqual :: FilePath -> FilePath -> IO Bool +filesEqual f1 f2 = do + ex1 <- doesFileExist f1 + ex2 <- doesFileExist f2 + if not (ex1 && ex2) + then return False + else withBinaryFile f1 ReadMode $ \h1 -> + withBinaryFile f2 ReadMode $ \h2 -> do + s1 <- hFileSize h1 + s2 <- hFileSize h2 + if s1 /= s2 + then return False + else do + c1 <- BSL.hGetContents h1 + c2 <- BSL.hGetContents h2 + return $! c1 == c2 diff --git a/src/Distribution/Compat/CreatePipe.hs b/src/Distribution/Compat/CreatePipe.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/CreatePipe.hs @@ -0,0 +1,5 @@ +module Distribution.Compat.CreatePipe + {-# DEPRECATED "Use System.Process from package process directly" #-} + (createPipe) where + +import System.Process (createPipe) diff --git a/src/Distribution/Compat/Directory.hs b/src/Distribution/Compat/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Directory.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} + +module Distribution.Compat.Directory + ( listDirectory + , makeAbsolute + , doesPathExist + ) where + +#if MIN_VERSION_directory(1,2,7) +import System.Directory as Dir hiding (doesPathExist) +import System.Directory (doesPathExist) +#else +import System.Directory as Dir +#endif +#if !MIN_VERSION_directory(1,2,2) +import System.FilePath as Path +#endif + +#if !MIN_VERSION_directory(1,2,5) + +listDirectory :: FilePath -> IO [FilePath] +listDirectory path = + filter f `fmap` Dir.getDirectoryContents path + where f filename = filename /= "." && filename /= ".." + +#endif + +#if !MIN_VERSION_directory(1,2,2) + +makeAbsolute :: FilePath -> IO FilePath +makeAbsolute p | Path.isAbsolute p = return p + | otherwise = do + cwd <- Dir.getCurrentDirectory + return $ cwd p + +#endif + +#if !MIN_VERSION_directory(1,2,7) + +doesPathExist :: FilePath -> IO Bool +doesPathExist path = do + -- not using Applicative, as this way we can do less IO + e <- doesDirectoryExist path + if e + then return True + else doesFileExist path + +#endif diff --git a/src/Distribution/Compat/Environment.hs b/src/Distribution/Compat/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Environment.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} + +module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv) +where + +import Distribution.Compat.Prelude +import Prelude () +import qualified Prelude + +import System.Environment (lookupEnv, unsetEnv) +import qualified System.Environment as System + +import Distribution.Compat.Stack + +#ifdef mingw32_HOST_OS +import Foreign.C +import GHC.Windows +#else +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Error (throwErrnoIfMinus1_) +import System.Posix.Internals ( withFilePath ) +#endif /* mingw32_HOST_OS */ + +getEnvironment :: IO [(String, String)] +#ifdef mingw32_HOST_OS +-- On Windows, the names of environment variables are case-insensitive, but are +-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise +-- them. +getEnvironment = fmap upcaseVars System.getEnvironment + where + upcaseVars = map upcaseVar + upcaseVar (var, val) = (map toUpper var, val) +#else +getEnvironment = System.getEnvironment +#endif + +-- | @setEnv name value@ sets the specified environment variable to @value@. +-- +-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the +-- empty string or contains an equals sign. +setEnv :: String -> String -> IO () +setEnv key value_ = setEnv_ key value + where + -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We + -- still strip it manually so that the null check above succeeds if a value + -- starts with NUL. + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () + +#ifdef mingw32_HOST_OS + +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + where + _ = callStack -- TODO: attach CallStack to exception + +{- FOURMOLU_DISABLE -} +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif /* i386_HOST_ARCH */ + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool +#else +setEnv_ key value = do + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + where + _ = callStack -- TODO: attach CallStack to exception + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt +#endif /* mingw32_HOST_OS */ +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Compat/FilePath.hs b/src/Distribution/Compat/FilePath.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/FilePath.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Distribution.Compat.FilePath + ( isExtensionOf + , stripExtension + ) where + +import Data.List (isSuffixOf, stripPrefix) +import System.FilePath + +#if !MIN_VERSION_filepath(1,4,2) +isExtensionOf :: String -> FilePath -> Bool +isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions +isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions +#endif + +#if !MIN_VERSION_filepath(1,4,1) +stripExtension :: String -> FilePath -> Maybe FilePath +stripExtension [] path = Just path +stripExtension ext@(x:_) path = stripSuffix dotExt path + where + dotExt = if isExtSeparator x then ext else '.':ext + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) +#endif diff --git a/src/Distribution/Compat/GetShortPathName.hs b/src/Distribution/Compat/GetShortPathName.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/GetShortPathName.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Compat.GetShortPathName +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : Windows-only +-- +-- Win32 API 'GetShortPathName' function. +module Distribution.Compat.GetShortPathName (getShortPathName) +where + +import Distribution.Compat.Prelude +import Prelude () + +#ifdef mingw32_HOST_OS + +import qualified Prelude +import qualified System.Win32 as Win32 +import System.Win32 (LPCTSTR, LPTSTR, DWORD) +import Foreign.Marshal.Array (allocaArray) + +{- FOURMOLU_DISABLE -} +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) +#define WINAPI ccall +#else +#define WINAPI stdcall +#endif + +foreign import WINAPI unsafe "windows.h GetShortPathNameW" + c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD + +-- | On Windows, retrieves the short path form of the specified path. On +-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185. +-- +-- From MS's GetShortPathName docs: +-- +-- Passing NULL for [the second] parameter and zero for cchBuffer +-- will always return the required buffer size for a +-- specified lpszLongPath. +-- +getShortPathName :: FilePath -> IO FilePath +getShortPathName path = + Win32.withTString path $ \c_path -> do + c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $ + c_GetShortPathName c_path Win32.nullPtr 0 + let arr_len = fromIntegral c_len + allocaArray arr_len $ \c_out -> do + void $ Win32.failIfZero "GetShortPathName #2 failed!" $ + c_GetShortPathName c_path c_out c_len + Win32.peekTString c_out + +#else + +getShortPathName :: FilePath -> IO FilePath +getShortPathName path = return path + +#endif +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Compat/Internal/TempFile.hs b/src/Distribution/Compat/Internal/TempFile.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Internal/TempFile.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} + +module Distribution.Compat.Internal.TempFile + ( openTempFile + , openBinaryTempFile + , openNewBinaryFile + , createTempDirectory + ) where + +import Distribution.Compat.Exception + +import System.FilePath (()) + +import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile) +import System.IO.Error (isAlreadyExistsError) +import System.Posix.Internals (c_getpid) + +#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFileWithDefaultPermissions + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let relpath = template ++ "-" ++ show x + dirpath = dir relpath + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> return relpath + Left e + | isAlreadyExistsError e -> findTempName (x + 1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/src/Distribution/Compat/Prelude/Internal.hs b/src/Distribution/Compat/Prelude/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Prelude/Internal.hs @@ -0,0 +1,14 @@ +-- | This module re-exports the non-exposed +-- "Distribution.Compat.Prelude" module for +-- reuse by @cabal-install@'s +-- "Distribution.Client.Compat.Prelude" module. +-- +-- It is highly discouraged to rely on this module +-- for @Setup.hs@ scripts since its API is /not/ +-- stable. +module Distribution.Compat.Prelude.Internal + {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} + ( module Distribution.Compat.Prelude + ) where + +import Distribution.Compat.Prelude diff --git a/src/Distribution/Compat/Process.hs b/src/Distribution/Compat/Process.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Process.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} + +module Distribution.Compat.Process + ( -- * Redefined functions + proc + + -- * Additions + , enableProcessJobs + ) where + +import System.Process (CreateProcess) +import qualified System.Process as Process + +#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) +import System.IO.Unsafe (unsafePerformIO) +import System.Win32.Info.Version (dwMajorVersion, dwMinorVersion, getVersionEx) +#endif + +------------------------------------------------------------------------------- +-- enableProcessJobs +------------------------------------------------------------------------------- + +#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) +-- This exception, needed to support Windows 7, could be removed when +-- the lowest GHC version cabal supports is a GHC that doesn’t support +-- Windows 7 any more. +{-# NOINLINE isWindows8OrLater #-} +isWindows8OrLater :: Bool +isWindows8OrLater = unsafePerformIO $ do + v <- getVersionEx + pure $ (dwMajorVersion v, dwMinorVersion v) >= (6, 2) +#endif + +-- | Enable process jobs to ensure accurate determination of process completion +-- in the presence of @exec(3)@ on Windows. +-- +-- Unfortunately the process job support is badly broken in @process@ releases +-- prior to 1.6.9, so we disable it in these versions, despite the fact that +-- this means we may see sporadic build failures without jobs. +-- +-- On Windows 7 or before the jobs are disabled due to the fact that +-- processes on these systems can only have one job. This prevents +-- spawned process from assigning jobs to its own children. Suppose +-- process A spawns process B. The B process has a job assigned (call +-- it J1) and when it tries to spawn a new process C the C +-- automatically inherits the job. But at it also tries to assign a +-- new job J2 to C since it doesn’t have access J1. This fails on +-- Windows 7 or before. +enableProcessJobs :: CreateProcess -> CreateProcess +#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) +enableProcessJobs cp = cp {Process.use_process_jobs = isWindows8OrLater} +#else +enableProcessJobs cp = cp +#endif + +------------------------------------------------------------------------------- +-- process redefinitions +------------------------------------------------------------------------------- + +-- | 'System.Process.proc' with process jobs enabled when appropriate, +-- and defaulting 'delegate_ctlc' to 'True'. +proc :: FilePath -> [String] -> CreateProcess +proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True} diff --git a/src/Distribution/Compat/ResponseFile.hs b/src/Distribution/Compat/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/ResponseFile.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- Compatibility layer for GHC.ResponseFile +-- Implementation from base 4.12.0 is used. +-- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE +module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where + +import Distribution.Compat.Prelude + +import GHC.ResponseFile (escapeArgs, unescapeArgs) + +import Prelude () + +import System.FilePath +import System.IO (hPutStrLn, stderr) +import System.IO.Error + +-- | The arg file / response file parser. +-- +-- This is not a well-documented capability, and is a bit eccentric +-- (try @cabal \@foo \@bar@ to see what that does), but is crucial +-- for allowing complex arguments to cabal and cabal-install when +-- using command prompts with strongly-limited argument length. +expandResponse :: [String] -> IO [String] +expandResponse = go recursionLimit "." + where + recursionLimit = 100 + + go :: Int -> FilePath -> [String] -> IO [String] + go n dir + | n >= 0 = fmap concat . traverse (expand n dir) + | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure + + expand :: Int -> FilePath -> String -> IO [String] + expand n dir arg@('@' : f) = readRecursively n (dir f) `catchIOError` const (print "?" >> return [arg]) + expand _n _dir x = return [x] + + readRecursively :: Int -> FilePath -> IO [String] + readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f diff --git a/src/Distribution/Compat/SnocList.hs b/src/Distribution/Compat/SnocList.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/SnocList.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Compat.SnocList +-- License : BSD3 +-- +-- Maintainer : cabal-dev@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A very reversed list. Has efficient `snoc` +module Distribution.Compat.SnocList + ( SnocList + , runSnocList + , snoc + ) where + +import Distribution.Compat.Prelude +import Prelude () + +newtype SnocList a = SnocList [a] + +snoc :: SnocList a -> a -> SnocList a +snoc (SnocList xs) x = SnocList (x : xs) + +runSnocList :: SnocList a -> [a] +runSnocList (SnocList xs) = reverse xs + +instance Semigroup (SnocList a) where + SnocList xs <> SnocList ys = SnocList (ys <> xs) + +instance Monoid (SnocList a) where + mempty = SnocList [] + mappend = (<>) diff --git a/src/Distribution/Compat/Stack.hs b/src/Distribution/Compat/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Stack.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Compat.Stack + ( WithCallStack + , CallStack + , annotateCallStackIO + , withFrozenCallStack + , withLexicalCallStack + , callStack + , prettyCallStack + , parentSrcLocPrefix + ) where + +import GHC.Stack +import System.IO.Error + +type WithCallStack a = HasCallStack => a + +-- | Give the *parent* of the person who invoked this; +-- so it's most suitable for being called from a utility function. +-- You probably want to call this using 'withFrozenCallStack'; otherwise +-- it's not very useful. We didn't implement this for base-4.8.1 +-- because we cannot rely on freezing to have taken place. +parentSrcLocPrefix :: WithCallStack String +parentSrcLocPrefix = + case getCallStack callStack of + (_ : (_, loc) : _) -> showLoc loc + [(_, loc)] -> showLoc loc + [] -> error "parentSrcLocPrefix: empty call stack" + where + showLoc loc = + srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": " + +-- Yeah, this uses skivvy implementation details. +withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) +withLexicalCallStack f = + let stk = ?callStack + in \x -> let ?callStack = stk in f x + +-- | This function is for when you *really* want to add a call +-- stack to raised IO, but you don't have a +-- 'Distribution.Verbosity.Verbosity' so you can't use +-- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity', +-- please use that function instead. +annotateCallStackIO :: WithCallStack (IO a -> IO a) +annotateCallStackIO = modifyIOError f + where + f ioe = + ioeSetErrorString ioe + . wrapCallStack + $ ioeGetErrorString ioe + wrapCallStack s = + prettyCallStack callStack ++ "\n" ++ s diff --git a/src/Distribution/Compat/Time.hs b/src/Distribution/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/Time.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Compat.Time + ( ModTime (..) -- Needed for testing + , getModTime + , getFileAge + , getCurTime + , posixSecondsToModTime + , calibrateMtimeChangeDelay + ) +where + +import Distribution.Compat.Prelude +import Prelude () + +import System.Directory (getModificationTime) + +import Distribution.Simple.Utils (withTempDirectoryCwd) +import Distribution.Utils.Path (getSymbolicPath, sameDirectory) +import Distribution.Verbosity (silent) + +import System.FilePath + +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength) + +#if defined mingw32_HOST_OS + +import qualified Prelude +import Data.Bits ((.|.), unsafeShiftL) +import Data.Bits (finiteBitSize) + +import Foreign ( allocaBytes, peekByteOff ) +import System.IO.Error ( mkIOError, doesNotExistErrorType ) +import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) + +#else + +import System.Posix.Files + ( FileStatus, getFileStatus +#if MIN_VERSION_unix(2,6,0) + , modificationTimeHiRes +#else + , modificationTime +#endif + ) + +#endif + +-- | An opaque type representing a file's modification time, represented +-- internally as a 64-bit unsigned integer in the Windows UTC format. +newtype ModTime = ModTime Word64 + deriving (Binary, Generic, Bounded, Eq, Ord) + +instance Structured ModTime + +instance Show ModTime where + show (ModTime x) = show x + +instance Read ModTime where + readsPrec p str = map (first ModTime) (readsPrec p str) + +-- | Return modification time of the given file. Works around the low clock +-- resolution problem that 'getModificationTime' has on GHC < 7.8. +-- +-- This is a modified version of the code originally written for Shake by Neil +-- Mitchell. See module Development.Shake.FileInfo. +getModTime :: FilePath -> IO ModTime + +#if defined mingw32_HOST_OS + +-- Directly against the Win32 API. +getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do + res <- getFileAttributesEx path info + if not res + then do + let err = mkIOError doesNotExistErrorType + "Distribution.Compat.Time.getModTime" + Nothing (Just path) + ioError err + else do + dwLow <- peekByteOff info + index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime + dwHigh <- peekByteOff info + index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime + let qwTime = + (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh) + .|. (fromIntegral (dwLow :: DWORD)) + return $! ModTime (qwTime :: Word64) + +{- FOURMOLU_DISABLE -} +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV "windows.h GetFileAttributesExW" + c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL + +getFileAttributesEx :: String -> LPVOID -> IO BOOL +getFileAttributesEx path lpFileInformation = + withTString path $ \c_path -> + c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation + +getFileExInfoStandard :: Int32 +getFileExInfoStandard = 0 + +size_WIN32_FILE_ATTRIBUTE_DATA :: Int +size_WIN32_FILE_ATTRIBUTE_DATA = 36 + +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20 + +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24 + +#else + +-- Directly against the unix library. +getModTime path = do + st <- getFileStatus path + return $! (extractFileTime st) + +extractFileTime :: FileStatus -> ModTime +extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) + +#endif +{- FOURMOLU_ENABLE -} + +windowsTick, secToUnixEpoch :: Word64 +windowsTick = 10000000 +secToUnixEpoch = 11644473600 + +-- | Convert POSIX seconds to ModTime. +posixSecondsToModTime :: Int64 -> ModTime +posixSecondsToModTime s = + ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick + +-- | Convert 'POSIXTime' to 'ModTime'. +posixTimeToModTime :: POSIXTime -> ModTime +posixTimeToModTime p = + ModTime $ + ceiling (p * 1e7) -- 100 ns precision + + (secToUnixEpoch * windowsTick) + +-- | Return age of given file in days. +getFileAge :: FilePath -> IO Double +getFileAge file = do + t0 <- getModificationTime file + t1 <- getCurrentTime + return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength + +-- | Return the current time as 'ModTime'. +getCurTime :: IO ModTime +getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. + +-- | Based on code written by Neil Mitchell for Shake. See +-- 'sleepFileTimeCalibrate' in 'Test.Type'. Returns a pair +-- of microsecond values: first, the maximum delay seen, and the +-- recommended delay to use before testing for file modification change. +-- The returned delay is never smaller +-- than 10 ms, but never larger than 1 second. +calibrateMtimeChangeDelay :: IO (Int, Int) +calibrateMtimeChangeDelay = + withTempDirectoryCwd silent Nothing sameDirectory "calibration-" $ \dir -> do + let fileName = getSymbolicPath dir "probe" + mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do + writeFile fileName $ show i + t0 <- getModTime fileName + let spin j = do + writeFile fileName $ show (i, j) + t1 <- getModTime fileName + unless (t0 < t1) (spin $ j + 1) + spin (0 :: Int) + let mtimeChange = maximum mtimes + mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 + return (mtimeChange, mtimeChange') + where + time :: IO () -> IO Int + time act = do + t0 <- getCurrentTime + act + t1 <- getCurrentTime + return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds diff --git a/src/Distribution/GetOpt.hs b/src/Distribution/GetOpt.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/GetOpt.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a fork of "System.Console.GetOpt" with the following changes: +-- +-- * Treat "cabal --flag command" as "cabal command --flag" e.g. +-- "cabal -v configure" to mean "cabal configure -v" For flags that are +-- not recognised as global flags, pass them on to the sub-command. See +-- the difference in 'shortOpt'. +-- +-- * Line wrapping in the 'usageInfo' output, plus a more compact +-- rendering of short options, and slightly less padding. +-- +-- * Parsing of option arguments is allowed to fail. +-- +-- * 'ReturnInOrder' argument order is removed. +module Distribution.GetOpt + ( -- * GetOpt + getOpt + , getOpt' + , usageInfo + , ArgOrder (..) + , OptDescr (..) + , ArgDescr (..) + + -- * Example + + -- | See "System.Console.GetOpt" for examples + ) where + +import Distribution.Compat.Prelude +import Prelude () + +-- | What to do with options following non-options +data ArgOrder a + = -- | no option processing after first non-option + RequireOrder + | -- | freely intersperse options and non-options + Permute + +data OptDescr a -- description of a single options: + = Option + [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +instance Functor OptDescr where + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + +-- | Describes whether an option takes an argument or not, and if so +-- how the argument is parsed to a value of type @a@. +-- +-- Compared to System.Console.GetOpt, we allow for parse errors. +data ArgDescr a + = -- | no argument expected + NoArg a + | -- | option requires argument + ReqArg (String -> Either String a) String + | -- | optional argument + OptArg String (Maybe String -> Either String a) String + +instance Functor ArgDescr where + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (fmap f . g) s + fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +data OptHelp = OptHelp + { optNames :: String + , optHelp :: String + } + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo + :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted description of options +usageInfo header optDescr = unlines (header : table) + where + options = flip map optDescr $ \(Option sos los ad d) -> + OptHelp + { optNames = + intercalate ", " $ + map (fmtShort ad) sos + ++ map (fmtLong ad) (take 1 los) + , optHelp = d + } + + maxOptNameWidth = 30 + descolWidth = 80 - (maxOptNameWidth + 3) + + table :: [String] + table = do + OptHelp{optNames, optHelp} <- options + let wrappedHelp = wrapText descolWidth optHelp + if length optNames >= maxOptNameWidth + then + [" " ++ optNames] + ++ renderColumns [] wrappedHelp + else renderColumns [optNames] wrappedHelp + + renderColumns :: [String] -> [String] -> [String] + renderColumns xs ys = do + (x, y) <- zipDefault "" "" xs ys + return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y + + padTo n x = take n (x ++ repeat ' ') + +zipDefault :: a -> b -> [a] -> [b] -> [(a, b)] +zipDefault _ _ [] [] = [] +zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as +zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs +zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs + +-- | Pretty printing of short options. +-- * With required arguments can be given as: +-- @-w PATH or -wPATH (but not -w=PATH)@ +-- This is displayed as: +-- @-w PATH or -wPATH@ +-- * With optional but default arguments can be given as: +-- @-j or -jNUM (but not -j=NUM or -j NUM)@ +-- This is displayed as: +-- @-j[NUM]@ +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = + let opt = "-" ++ [so] + in opt ++ " " ++ ad ++ " or " ++ opt ++ ad +fmtShort (OptArg _ _ ad) so = + let opt = "-" ++ [so] + in opt ++ "[" ++ ad ++ "]" + +-- | Pretty printing of long options. +-- * With required arguments can be given as: +-- @--with-compiler=PATH (but not --with-compiler PATH)@ +-- This is displayed as: +-- @--with-compiler=PATH@ +-- * With optional but default arguments can be given as: +-- @--jobs or --jobs=NUM (but not --jobs NUM)@ +-- This is displayed as: +-- @--jobs[=NUM]@ +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = + let opt = "--" ++ lo + in opt ++ "=" ++ ad +fmtLong (OptArg _ _ ad) lo = + let opt = "--" ++ lo + in opt ++ "[=" ++ ad ++ "]" + +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where + wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w : ws) + | length w + 1 > width = + wrap (length w) [w] ws + wrap col line (w : ws) + | col + length w + 1 > width = + reverse line : wrap 0 [] (w : ws) + wrap col line (w : ws) = + let col' = col + length w + 1 + in wrap col' (w : line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- | +-- Process the command-line, and return the list of values that matched +-- (and those that didn\'t). The arguments are: +-- +-- * The order requirements (see 'ArgOrder') +-- +-- * The option descriptions (see 'OptDescr') +-- +-- * The actual command line arguments (presumably got from +-- 'System.Environment.getArgs'). +-- +-- 'getOpt' returns a triple consisting of the option arguments, a list +-- of non-options, and a list of error messages. +getOpt + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us) + where + (os, xs, us, es) = getOpt' ordering optDescr args + +-- | +-- This is almost the same as 'getOpt', but returns a quadruple +-- consisting of the option arguments, a list of non-options, a list of +-- unrecognized options, and a list of error messages. +getOpt' + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([], [], [], []) +getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering + where + procNextOpt (Opt o) _ = (o : os, xs, us, es) + procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es) + procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], []) + procNextOpt (NonOpt x) Permute = (os, x : xs, us, es) + procNextOpt EndOfOpts RequireOrder = ([], rest, [], []) + procNextOpt EndOfOpts Permute = ([], rest, [], []) + procNextOpt (OptErr e) _ = (os, xs, us, e : es) + + (opt, rest) = getNext arg args optDescr + (os, xs, us, es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) +getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest) +getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr +getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a, rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) +longOpt ls rs optDescr = long ads arg rs + where + (opt, arg) = break (== '=') ls + getWith p = + [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs) + ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ad | Option _ _ ad _ <- options] + optStr = "--" ++ opt + fromRes = fromParseResult optStr + + long (_ : _ : _) _ rest = (errAmbig options optStr, rest) + long [NoArg a] [] rest = (Opt a, rest) + long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest) + long [ReqArg _ d] [] [] = (errReq d optStr, []) + long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest) + long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest) + long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest) + long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest) + long _ _ rest = (UnreqOpt ("--" ++ ls), rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String]) +shortOpt y ys rs optDescr = short ads ys rs + where + options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s] + ads = [ad | Option _ _ ad _ <- options] + optStr = '-' : [y] + fromRes = fromParseResult optStr + + short (_ : _ : _) _ rest = (errAmbig options optStr, rest) + short (NoArg a : _) [] rest = (Opt a, rest) + short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest) + short (ReqArg _ d : _) [] [] = (errReq d optStr, []) + short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest) + short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest) + short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest) + short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest) + short [] [] rest = (UnreqOpt optStr, rest) + short [] xs rest = (UnreqOpt (optStr ++ xs), rest) + +-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) +-- Apparently this was part of the change so that flags that are +-- not recognised as global flags are passed on to the sub-command. +-- But why was no equivalent change required for longOpt? So could +-- this change go upstream? + +fromParseResult :: String -> Either String a -> OptKind a +fromParseResult optStr res = case res of + Right x -> Opt x + Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind b +errAmbig ods optStr = OptErr (usageInfo header ods) + where + header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") diff --git a/src/Distribution/Lex.hs b/src/Distribution/Lex.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Lex.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Lex +-- Copyright : Ben Gamari 2015-2019 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains a simple lexer supporting quoted strings +module Distribution.Lex + ( tokenizeQuotedWords + ) where + +import Distribution.Compat.DList +import Distribution.Compat.Prelude +import Prelude () + +-- | A simple parser supporting quoted strings. +-- +-- Please be aware that this will only split strings when seeing whitespace +-- outside of quotation marks, i.e, @"foo\"bar baz\"qux quux"@ will be +-- converted to @["foobar bazqux", "quux"]@. +-- +-- This behavior can be useful when parsing text like +-- @"ghc-options: -Wl,\"some option with spaces\""@, for instance. +tokenizeQuotedWords :: String -> [String] +tokenizeQuotedWords = filter (not . null) . go False mempty + where + go + :: Bool + -- \^ in quoted region + -> DList Char + -- \^ accumulator + -> String + -- \^ string to be parsed + -> [String] + -- \^ parse result + go _ accum [] + | [] <- accum' = [] + | otherwise = [accum'] + where + accum' = runDList accum + go False accum (c : cs) + | isSpace c = runDList accum : go False mempty cs + | c == '"' = go True accum cs + go True accum (c : cs) + | c == '"' = go False accum cs + go quoted accum (c : cs) = + go quoted (accum `mappend` singleton c) cs diff --git a/src/Distribution/Make.hs b/src/Distribution/Make.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Make.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- that it works. +-- +-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build +-- Haskell tools using a back-end build system based on make. Obviously we +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. +module Distribution.Make + ( module Distribution.Package + , License (..) + , Version + , defaultMain + , defaultMainArgs + ) where + +import Distribution.Compat.Prelude +import Prelude () + +-- local +import Distribution.License +import Distribution.Package +import Distribution.Pretty +import Distribution.Simple.Command +import Distribution.Simple.Program +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.Version + +import System.Environment (getArgs, getProgName) + +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainArgs + +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper + +defaultMainHelper :: [String] -> IO () +defaultMainHelper args = do + command <- commandsRun (globalCommand commands) commands args + case command of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ + | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ prettyShow cabalVersion + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion + progs = defaultProgramDb + commands = + [ configureCommand progs `commandAddAction` configureAction + , buildCommand progs `commandAddAction` buildAction + , installCommand `commandAddAction` installAction + , copyCommand `commandAddAction` copyAction + , haddockCommand `commandAddAction` haddockAction + , cleanCommand `commandAddAction` cleanAction + , sdistCommand `commandAddAction` sdistAction + , registerCommand `commandAddAction` registerAction + , unregisterCommand `commandAddAction` unregisterAction + ] + +configureAction :: ConfigFlags -> [String] -> IO () +configureAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ configVerbosity flags + mbWorkDir = flagToMaybe $ configWorkingDir flags + rawSystemExit verbosity mbWorkDir "sh" $ + "configure" + : configureArgs backwardsCompatHack flags + where + backwardsCompatHack = True + +copyAction :: CopyFlags -> [String] -> IO () +copyAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ copyVerbosity flags + mbWorkDir = flagToMaybe $ copyWorkingDir flags + destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + CopyToDb _ -> error "CopyToDb not supported via Make" + + rawSystemExit verbosity mbWorkDir "make" destArgs + +installAction :: InstallFlags -> [String] -> IO () +installAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ installVerbosity flags + mbWorkDir = flagToMaybe $ installWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["install"] + rawSystemExit verbosity mbWorkDir "make" ["register"] + +haddockAction :: HaddockFlags -> [String] -> IO () +haddockAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ haddockVerbosity flags + mbWorkDir = flagToMaybe $ haddockWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["docs"] + `catchIO` \_ -> + rawSystemExit verbosity mbWorkDir "make" ["doc"] + +buildAction :: BuildFlags -> [String] -> IO () +buildAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ buildVerbosity flags + mbWorkDir = flagToMaybe $ buildWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" [] + +cleanAction :: CleanFlags -> [String] -> IO () +cleanAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ cleanVerbosity flags + mbWorkDir = flagToMaybe $ cleanWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["clean"] + +sdistAction :: SDistFlags -> [String] -> IO () +sdistAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ sDistVerbosity flags + mbWorkDir = flagToMaybe $ sDistWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["dist"] + +registerAction :: RegisterFlags -> [String] -> IO () +registerAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ registerVerbosity flags + mbWorkDir = flagToMaybe $ registerWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["register"] + +unregisterAction :: RegisterFlags -> [String] -> IO () +unregisterAction flags args = do + noExtraFlags args + let verbosity = fromFlag $ registerVerbosity flags + mbWorkDir = flagToMaybe $ registerWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["unregister"] diff --git a/src/Distribution/PackageDescription/Check.hs b/src/Distribution/PackageDescription/Check.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check.hs @@ -0,0 +1,1111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2022 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of checks so we can see which ones are appropriate to report +-- in different situations. This code gets used when configuring a package when +-- we consider only basic problems. The higher standard is used when +-- preparing a source tarball and by Hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. +module Distribution.PackageDescription.Check + ( -- * Package Checking + CheckExplanation (..) + , CheckExplanationID + , CheckExplanationIDString + , PackageCheck (..) + , checkPackage + , checkConfiguredPackage + , wrapParseWarning + , ppPackageCheck + , ppCheckExplanationId + , isHackageDistError + , filterPackageChecksById + , filterPackageChecksByIdString + + -- ** Checking package contents + , checkPackageFiles + , checkPackageFilesGPD + , checkPackageContent + , CheckPackageContentOps (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.List (group) +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.License +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Conditional +import Distribution.PackageDescription.Check.Monad +import Distribution.PackageDescription.Check.Paths +import Distribution.PackageDescription.Check.Target +import Distribution.PackageDescription.Check.Warning +import Distribution.Parsec.Warning (PWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.Glob + ( Glob + , GlobResult (..) + , globMatches + , parseFileGlob + , runDirFileGlob + ) +import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import System.FilePath (splitExtension, takeFileName) + +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.SPDX as SPDX +import qualified System.Directory as System + +import qualified System.Directory (getDirectoryContents) +import qualified System.FilePath.Windows as FilePath.Windows (isValid) + +import qualified Data.Set as Set +import qualified Distribution.Utils.ShortText as ShortText + +import qualified Distribution.Types.GenericPackageDescription.Lens as L + +import Control.Monad + +-- $setup +-- >>> import Control.Arrow ((&&&)) + +-- ☞ N.B. +-- +-- Part of the tools/scaffold used to perform check is found in +-- Distribution.PackageDescription.Check.Types. Summary of that module (for +-- how we use it here): +-- 1. we work inside a 'CheckM m a' monad (where `m` is an abstraction to +-- run non-pure checks); +-- 2. 'checkP', 'checkPre' functions perform checks (respectively pure and +-- non-pure); +-- 3. 'PackageCheck' and 'CheckExplanation' are types for warning severity +-- and description. + +-- ------------------------------------------------------------ +-- Checking interface +-- ------------------------------------------------------------ + +-- | 'checkPackagePrim' is the most general way to invoke package checks. +-- We pass to it two interfaces (one to check contents of packages, the +-- other to inspect working tree for orphan files) and before that a +-- Boolean to indicate whether we want pure checks or not. Based on these +-- parameters, some checks will be performed, some omitted. +-- Generality over @m@ means we could do non pure checks in monads other +-- than IO (e.g. a virtual filesystem, like a zip file, a VCS filesystem, +-- etc). +checkPackagePrim + :: Monad m + => Bool -- Perform pure checks? + -> Maybe (CheckPackageContentOps m) -- Package content interface. + -> Maybe (CheckPreDistributionOps m) -- Predist checks interface. + -> GenericPackageDescription -- GPD to check. + -> m [PackageCheck] +checkPackagePrim b mco mpdo gpd = do + let cm = checkGenericPackageDescription gpd + ci = CheckInterface b mco mpdo + ctx = pristineCheckCtx ci gpd + execCheckM cm ctx + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all aspects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +checkPackage :: GenericPackageDescription -> [PackageCheck] +checkPackage gpd = runIdentity $ checkPackagePrim True Nothing Nothing gpd + +-- | This function is an oddity due to the historical +-- GenericPackageDescription/PackageDescription split. It is only maintained +-- not to break interface, use `checkPackage` if possible. +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pd = checkPackage (pd2gpd pd) + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +checkPackageContent + :: Monad m + => CheckPackageContentOps m + -> GenericPackageDescription + -> m [PackageCheck] +checkPackageContent pops gpd = checkPackagePrim False (Just pops) Nothing gpd + +-- | Sanity checks that require IO. 'checkPackageFiles' looks at the files +-- in the package and expects to find the package unpacked at the given +-- filepath. +checkPackageFilesGPD + :: Verbosity -- Glob warn message verbosity. + -> GenericPackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] +checkPackageFilesGPD verbosity gpd root = + checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd + where + checkFilesIO = + CheckPackageContentOps + { doesFileExist = System.doesFileExist . relative + , doesDirectoryExist = System.doesDirectoryExist . relative + , getDirectoryContents = System.Directory.getDirectoryContents . relative + , getFileContents = BS.readFile . relative + } + + checkPreIO = + CheckPreDistributionOps + { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root fp) g + , getDirectoryContentsM = System.Directory.getDirectoryContents . relative + } + + relative :: FilePath -> FilePath + relative path = root path + +-- | Same as 'checkPackageFilesGPD', but working with 'PackageDescription'. +-- +-- This function is included for legacy reasons, use 'checkPackageFilesGPD' +-- if you are working with 'GenericPackageDescription'. +checkPackageFiles + :: Verbosity -- Glob warn message verbosity. + -> PackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] +checkPackageFiles verbosity pd oot = + checkPackageFilesGPD verbosity (pd2gpd pd) oot + +-- ------------------------------------------------------------ +-- Package description +-- ------------------------------------------------------------ + +-- Here lies the meat of the module. Starting from 'GenericPackageDescription', +-- we walk the data while doing a number of checks. +-- +-- Where applicable we do a full pattern match (if the data changes, code will +-- break: a gentle reminder to add more checks). +-- Pattern matching variables convention: matching accessor + underscore. +-- This way it is easier to see which one we are missing if we run into +-- an “GPD should have 20 arguments but has been given only 19” error. + +-- | 'GenericPackageDescription' checks. Remember that for historical quirks +-- in the cabal codebase we have both `GenericPackageDescription` and +-- `PackageDescription` and that PD is both a *field* of GPD and a concept +-- of its own (i.e. a fully realised GPD). +-- In this case we are checking (correctly) GPD, so for target info/checks +-- you should walk condLibrary_ etc. and *not* the (empty) target info in +-- PD. See 'pd2gpd' for a convenient hack when you only have +-- 'PackageDescription'. +checkGenericPackageDescription + :: Monad m + => GenericPackageDescription + -> CheckM m () +checkGenericPackageDescription + gpd@( GenericPackageDescription + packageDescription_ + _gpdScannedVersion_ + genPackageFlags_ + condLibrary_ + condSubLibraries_ + condForeignLibs_ + condExecutables_ + condTestSuites_ + condBenchmarks_ + ) = + do + -- § Description and names. + checkPackageDescription packageDescription_ + -- Targets should be present... + let condAllLibraries = + maybeToList condLibrary_ + ++ (map snd condSubLibraries_) + checkP + ( and + [ null condExecutables_ + , null condTestSuites_ + , null condBenchmarks_ + , null condAllLibraries + , null condForeignLibs_ + ] + ) + (PackageBuildImpossible NoTarget) + -- ... and have unique names (names are not under conditional, it is + -- appropriate to check here. + (nsubs, nexes, ntests, nbenchs) <- + asksCM + ( ( \n -> + ( pnSubLibs n + , pnExecs n + , pnTests n + , pnBenchs n + ) + ) + . ccNames + ) + let names = concat [nsubs, nexes, ntests, nbenchs] + dupes = dups names + checkP + (not . null $ dups names) + (PackageBuildImpossible $ DuplicateSections dupes) + -- Flag names. + mapM_ checkFlagName genPackageFlags_ + + -- § Feature checks. + checkSpecVer + CabalSpecV2_0 + (not . null $ condSubLibraries_) + (PackageDistInexcusable CVMultiLib) + checkSpecVer + CabalSpecV1_8 + (not . null $ condTestSuites_) + (PackageDistInexcusable CVTestSuite) + + -- § Conditional targets + + -- Extract dependencies from libraries, to be passed along for + -- PVP checks purposes. + pName <- + asksCM + ( packageNameToUnqualComponentName + . pkgName + . pnPackageId + . ccNames + ) + let ads = + maybe [] ((: []) . extractAssocDeps pName) condLibrary_ + ++ map (uncurry extractAssocDeps) condSubLibraries_ + + case condLibrary_ of + Just cl -> + checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (const id) + (mempty, cl) + Nothing -> return () + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (\u l -> l{libName = maybeToLibraryName (Just u)}) + ) + condSubLibraries_ + mapM_ + ( checkCondTarget + genPackageFlags_ + checkForeignLib + (const id) + ) + condForeignLibs_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkExecutable ads) + (const id) + ) + condExecutables_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkTestSuite ads) + (\u l -> l{testName = u}) + ) + condTestSuites_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkBenchmark ads) + (\u l -> l{benchmarkName = u}) + ) + condBenchmarks_ + + -- For unused flags it is clearer and more convenient to fold the + -- data rather than walk it, an exception to the rule. + checkP + (decFlags /= usedFlags) + (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags) + + -- Duplicate modules. + mapM_ tellP (checkDuplicateModules gpd) + where + -- todo is this caught at parse time? + checkFlagName :: Monad m => PackageFlag -> CheckM m () + checkFlagName pf = + let fn = unFlagName . flagName $ pf + + invalidFlagName ('-' : _) = True -- starts with dash + invalidFlagName cs = any (not . isAscii) cs -- non ASCII + in checkP + (invalidFlagName fn) + (PackageDistInexcusable $ SuspiciousFlagName [fn]) + + decFlags :: Set.Set FlagName + decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd + + usedFlags :: Set.Set FlagName + usedFlags = + mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + ] + +checkPackageDescription :: Monad m => PackageDescription -> CheckM m () +checkPackageDescription + pkg@( PackageDescription + specVersion_ + package_ + licenseRaw_ + licenseFiles_ + _copyright_ + maintainer_ + _author_ + _stability_ + testedWith_ + _homepage_ + _pkgUrl_ + _bugReports_ + sourceRepos_ + synopsis_ + description_ + category_ + customFieldsPD_ + buildTypeRaw_ + setupBuildInfo_ + _library_ + _subLibraries_ + _executables_ + _foreignLibs_ + _testSuites_ + _benchmarks_ + dataFiles_ + dataDir_ + extraSrcFiles_ + extraTmpFiles_ + extraDocFiles_ + extraFiles_ + ) = do + -- § Sanity checks. + checkPackageId package_ + -- TODO `name` is caught at parse level, remove this test. + let pn = packageName package_ + checkP + (null . unPackageName $ pn) + (PackageBuildImpossible NoNameField) + -- TODO `version` is caught at parse level, remove this test. + checkP + (nullVersion == packageVersion package_) + (PackageBuildImpossible NoVersionField) + -- But it is OK for executables to have the same name. + nsubs <- asksCM (pnSubLibs . ccNames) + checkP + (any (== prettyShow pn) (prettyShow <$> nsubs)) + (PackageBuildImpossible $ IllegalLibraryName pn) + + -- § Fields check. + checkNull + category_ + (PackageDistSuspicious MissingFieldCategory) + checkNull + maintainer_ + (PackageDistSuspicious MissingFieldMaintainer) + checkP + (ShortText.null synopsis_ && not (ShortText.null description_)) + (PackageDistSuspicious MissingFieldSynopsis) + checkP + (ShortText.null description_ && not (ShortText.null synopsis_)) + (PackageDistSuspicious MissingFieldDescription) + checkP + (all ShortText.null [synopsis_, description_]) + (PackageDistInexcusable MissingFieldSynOrDesc) + checkP + (ShortText.length synopsis_ > 80) + (PackageDistSuspicious SynopsisTooLong) + checkP + ( not (ShortText.null description_) + && ShortText.length description_ <= ShortText.length synopsis_ + ) + (PackageDistSuspicious ShortDesc) + + -- § Paths. + mapM_ (checkPath False "extra-source-files" PathKindGlob . getSymbolicPath) extraSrcFiles_ + mapM_ (checkPath False "extra-tmp-files" PathKindFile . getSymbolicPath) extraTmpFiles_ + mapM_ (checkPath False "extra-doc-files" PathKindGlob . getSymbolicPath) extraDocFiles_ + mapM_ (checkPath False "extra-files" PathKindGlob . getSymbolicPath) extraFiles_ + mapM_ (checkPath False "data-files" PathKindGlob . getSymbolicPath) dataFiles_ + let rawDataDir = getSymbolicPath dataDir_ + checkPath True "data-dir" PathKindDirectory rawDataDir + let licPaths = map getSymbolicPath licenseFiles_ + mapM_ (checkPath False "license-file" PathKindFile) licPaths + mapM_ checkLicFileExist licenseFiles_ + + -- § Globs. + dataGlobs <- mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_ + extraSrcGlobs <- mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_ + docGlobs <- mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_ + extraGlobs <- mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_ + -- We collect globs to feed them to checkMissingDocs. + + -- § Missing documentation. + checkMissingDocs + (catMaybes dataGlobs) + (catMaybes extraSrcGlobs) + (catMaybes docGlobs) + (catMaybes extraGlobs) + + -- § Datafield checks. + checkSetupBuildInfo setupBuildInfo_ + mapM_ checkTestedWith testedWith_ + either + checkNewLicense + (checkOldLicense $ null licenseFiles_) + licenseRaw_ + checkSourceRepos sourceRepos_ + mapM_ checkCustomField customFieldsPD_ + + -- Feature checks. + checkSpecVer + CabalSpecV1_18 + (not . null $ extraDocFiles_) + (PackageDistInexcusable CVExtraDocFiles) + checkSpecVer + CabalSpecV1_6 + (not . null $ sourceRepos_) + (PackageDistInexcusable CVSourceRepository) + checkP + ( specVersion_ >= CabalSpecV1_24 + && isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageBuildWarning CVCustomSetup) + checkSpecVer + CabalSpecV1_24 + ( isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + checkP + (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) + (PackageBuildWarning NoBuildType) + checkP + (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks]) + (PackageBuildWarning NoCustomSetup) + + -- Contents. + checkConfigureExists (buildType pkg) + checkSetupExists (buildType pkg) + checkCabalFile (packageName pkg) + mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_ + mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_ + mapM_ (checkGlobFile specVersion_ "." "extra-files" . getSymbolicPath) extraFiles_ + mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_ + where + checkNull + :: Monad m + => ShortText.ShortText + -> PackageCheck + -> CheckM m () + checkNull st c = checkP (ShortText.null st) c + + checkTestedWith + :: Monad m + => (CompilerFlavor, VersionRange) + -> CheckM m () + checkTestedWith (OtherCompiler n, _) = + tellP (PackageBuildWarning $ UnknownCompilers [n]) + checkTestedWith (compiler, versionRange) = + checkVersionRange compiler versionRange + + checkVersionRange + :: Monad m + => CompilerFlavor + -> VersionRange + -> CheckM m () + checkVersionRange cmp vr = + when + (isNoVersion vr) + ( let dep = + [ Dependency + (mkPackageName (prettyShow cmp)) + vr + mainLibSet + ] + in tellP (PackageDistInexcusable (InvalidTestWith dep)) + ) + +checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m () +checkSetupBuildInfo Nothing = return () +checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do + let uqs = map mkUnqualComponentName ["base", "Cabal"] + (is, rs) <- partitionDeps [] uqs ds + let ick = PackageDistInexcusable . UpperBoundSetup + rck = + PackageDistSuspiciousWarn + . MissingUpperBounds CETSetup + leuck = + PackageDistSuspiciousWarn + . LEUpperBounds CETSetup + tzuck = + PackageDistSuspiciousWarn + . TrailingZeroUpperBounds CETSetup + gtlck = + PackageDistSuspiciousWarn + . GTLowerBounds CETSetup + checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick is + checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rs + checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds + checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds + checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds + +checkPackageId :: Monad m => PackageIdentifier -> CheckM m () +checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do + checkP + (not . FilePath.Windows.isValid . prettyShow $ pkgName_) + (PackageDistInexcusable $ InvalidNameWin pkgName_) + checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $ + (PackageDistInexcusable ZPrefix) + +checkNewLicense :: Monad m => SPDX.License -> CheckM m () +checkNewLicense lic = do + checkP + (lic == SPDX.NONE) + (PackageDistInexcusable NONELicense) + +checkOldLicense + :: Monad m + => Bool -- Flag: no license file? + -> License + -> CheckM m () +checkOldLicense nullLicFiles lic = do + checkP + (lic == UnspecifiedLicense) + (PackageDistInexcusable NoLicense) + checkP + (lic == AllRightsReserved) + (PackageDistSuspicious AllRightsReservedLicense) + checkSpecVer + CabalSpecV1_4 + (lic `notElem` compatLicenses) + (PackageDistInexcusable (LicenseMessParse lic)) + checkP + (lic == BSD4) + (PackageDistSuspicious UncommonBSD4) + case lic of + UnknownLicense l -> + tellP (PackageBuildWarning (UnrecognisedLicense l)) + _ -> return () + checkP + ( lic + `notElem` [ AllRightsReserved + , UnspecifiedLicense + , PublicDomain + ] + && + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + nullLicFiles + ) + $ (PackageDistSuspicious NoLicenseFile) + case unknownLicenseVersion lic of + Just knownVersions -> + tellP + (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions) + _ -> return () + where + compatLicenses = + [ GPL Nothing + , LGPL Nothing + , AGPL Nothing + , BSD3 + , BSD4 + , PublicDomain + , AllRightsReserved + , UnspecifiedLicense + , OtherLicense + ] + + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | GPL (Just v') <- knownLicenses] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | LGPL (Just v') <- knownLicenses] + unknownLicenseVersion (AGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | AGPL (Just v') <- knownLicenses] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | Apache (Just v') <- knownLicenses] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: Monad m => [SourceRepo] -> CheckM m () +checkSourceRepos rs = do + mapM_ repoCheck rs + checkMissingVcsInfo rs + where + -- Single repository checks. + repoCheck :: Monad m => SourceRepo -> CheckM m () + repoCheck + ( SourceRepo + repoKind_ + repoType_ + repoLocation_ + repoModule_ + _repoBranch_ + repoTag_ + repoSubdir_ + ) = do + case repoKind_ of + RepoKindUnknown kind -> + tellP + (PackageDistInexcusable $ UnrecognisedSourceRepo kind) + _ -> return () + checkP + (isNothing repoType_) + (PackageDistInexcusable MissingType) + checkP + (isNothing repoLocation_) + (PackageDistInexcusable MissingLocation) + checkGitProtocol repoLocation_ + checkP + ( repoType_ == Just (KnownRepoType CVS) + && isNothing repoModule_ + ) + (PackageDistInexcusable MissingModule) + checkP + (repoKind_ == RepoThis && isNothing repoTag_) + (PackageDistInexcusable MissingTag) + checkP + (any isAbsoluteOnAnyPlatform repoSubdir_) + (PackageDistInexcusable SubdirRelPath) + case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of + Just err -> + tellP + (PackageDistInexcusable $ SubdirGoodRelPath err) + Nothing -> return () + +checkMissingVcsInfo :: Monad m => [SourceRepo] -> CheckM m () +checkMissingVcsInfo rs = + let rdirs = concatMap repoTypeDirname knownRepoTypes + in checkPkg + ( \ops -> do + us <- or <$> traverse (doesDirectoryExist ops) rdirs + return (null rs && us) + ) + (PackageDistSuspicious MissingSourceControl) + where + repoTypeDirname :: KnownRepoType -> [FilePath] + repoTypeDirname Darcs = ["_darcs"] + repoTypeDirname Git = [".git"] + repoTypeDirname SVN = [".svn"] + repoTypeDirname CVS = ["CVS"] + repoTypeDirname Mercurial = [".hg"] + repoTypeDirname GnuArch = [".arch-params"] + repoTypeDirname Bazaar = [".bzr"] + repoTypeDirname Monotone = ["_MTN"] + repoTypeDirname Pijul = [".pijul"] + +-- git:// lacks TLS or other encryption, see +-- https://git-scm.com/book/en/v2/Git-on-the-Server-The-Protocols#_the_cons_4 +checkGitProtocol + :: Monad m + => Maybe String -- Repository location + -> CheckM m () +checkGitProtocol mloc = + checkP + (fmap (isPrefixOf "git://") mloc == Just True) + (PackageBuildWarning GitProtocol) + +-- ------------------------------------------------------------ +-- Package and distribution checks +-- ------------------------------------------------------------ + +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', +-- but generalized over monads. +findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath] +findPackageDesc ops = do + let dir = "." + files <- getDirectoryContents ops dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .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/ReadE.hs b/src/Distribution/ReadE.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ReadE.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple parsing with failure +module Distribution.ReadE + ( -- * ReadE + ReadE (..) + , succeedReadE + , failReadE + + -- * Projections + , parsecToReadE + , parsecToReadEErr + + -- * Parse Errors + , unexpectMsgString + ) where + +import qualified Data.Bifunctor as Bi (first) +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Parsec.FieldLineStream +import qualified Text.Parsec.Error as Parsec + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} + +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +succeedReadE :: (String -> a) -> ReadE a +succeedReadE f = ReadE (Right . f) + +failReadE :: ErrorMsg -> ReadE a +failReadE = ReadE . const . Left + +runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a +runParsecFromString p txt = + runParsecParser p "" (fieldLineStreamFromString txt) + +parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadE err p = ReadE $ \txt -> + const (err txt) `Bi.first` runParsecFromString p txt + +parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadEErr err p = + ReadE $ + Bi.first err . runParsecFromString p + +-- Show only unexpected error messages +unexpectMsgString :: Parsec.ParseError -> String +unexpectMsgString = + unlines + . map Parsec.messageString + . filter (\case Parsec.UnExpect _ -> True; _ -> False) + . Parsec.errorMessages diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple.hs @@ -0,0 +1,1132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. +module Distribution.Simple + ( module Distribution.Package + , module Distribution.Version + , module Distribution.License + , module Distribution.Simple.Compiler + , module Language.Haskell.Extension + + -- * Simple interface + , defaultMain + , defaultMainNoRead + , defaultMainArgs + + -- * Customization + , UserHooks (..) + , Args + , defaultMainWithHooks + , defaultMainWithSetupHooks + , defaultMainWithSetupHooksArgs + , defaultMainWithHooksArgs + , defaultMainWithHooksNoRead + , defaultMainWithHooksNoReadArgs + + -- ** Standard sets of hooks + , simpleUserHooks + , autoconfUserHooks + , autoconfSetupHooks + , emptyUserHooks + ) where + +import Control.Exception (try) + +import Distribution.Compat.Prelude +import Distribution.Compat.ResponseFile (expandResponse) +import Prelude () + +-- local + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.Simple.Command +import Distribution.Simple.Compiler +import Distribution.Simple.PackageDescription +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Setup +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import Distribution.Simple.UserHooks + +import Distribution.Simple.Build +import Distribution.Simple.Register +import Distribution.Simple.SrcDist + +import Distribution.Simple.Configure + +import Distribution.License +import Distribution.Pretty +import Distribution.Simple.Bench +import Distribution.Simple.BuildPaths +import Distribution.Simple.ConfigureScript (runConfigureScript) +import Distribution.Simple.Errors +import Distribution.Simple.Haddock +import Distribution.Simple.Install +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.SetupHooks.Internal + ( SetupHooks + ) +import Distribution.Simple.Test +import Distribution.Simple.Utils +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension + +-- Base +import Data.List (unionBy, (\\)) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + , removeFile + ) +import System.Environment (getArgs, getProgName) + +-- | A simple implementation of @main@ for a Cabal setup script. +-- It reads the package description file using IO, and performs the +-- action specified on the command line. +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +defaultMainWithSetupHooks :: SetupHooks -> IO () +defaultMainWithSetupHooks setup_hooks = + getArgs >>= defaultMainWithSetupHooksArgs setup_hooks + +defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO () +defaultMainWithSetupHooksArgs setupHooks = + defaultMainHelper $ + simpleUserHooks + { confHook = setup_confHook + , buildHook = setup_buildHook + , copyHook = setup_copyHook + , instHook = setup_installHook + , replHook = setup_replHook + , haddockHook = setup_haddockHook + , hscolourHook = setup_hscolourHook + } + where + setup_confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + setup_confHook = + configure_setupHooks + (SetupHooks.configureHooks setupHooks) + + setup_buildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () + setup_buildHook pkg_descr lbi hooks flags = + build_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + + setup_copyHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> CopyFlags + -> IO () + setup_copyHook pkg_descr lbi _hooks flags = + install_setupHooks + (SetupHooks.installHooks setupHooks) + pkg_descr + lbi + flags + + setup_installHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () + setup_installHook = + defaultInstallHook_setupHooks + (SetupHooks.installHooks setupHooks) + + setup_replHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () + setup_replHook pkg_descr lbi hooks flags args = + repl_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + args + + setup_haddockHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HaddockFlags + -> IO () + setup_haddockHook pkg_descr lbi hooks flags = + haddock_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + + setup_hscolourHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HscolourFlags + -> IO () + setup_hscolourHook pkg_descr lbi hooks flags = + hscolour_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks + +-- | A customizable version of 'defaultMainNoRead'. +defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () +defaultMainWithHooksNoRead hooks pkg_descr = + getArgs + >>= defaultMainHelper hooks{readDesc = return (Just pkg_descr)} + +-- | A customizable version of 'defaultMainNoRead' that also takes the +-- command line arguments. +-- +-- @since 2.2.0.0 +defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () +defaultMainWithHooksNoReadArgs hooks pkg_descr = + defaultMainHelper hooks{readDesc = return (Just pkg_descr)} + +-- | The central command chooser of the Simple build system, +-- with other defaultMain functions acting as exposed callers, +-- and with 'topHandler' operating as an exceptions handler. +-- +-- This uses 'expandResponse' to read response files, preprocessing +-- response files given by "@" prefixes. +-- +-- Given hooks and args, this runs 'commandsRun' onto the args, +-- getting 'CommandParse' data back, which is then pattern-matched into +-- IO actions for execution, with arguments applied by the parser. +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ do + args' <- expandResponse args + command <- commandsRun (globalCommand commands) commands args' + case command of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ + | fromFlag (globalVersion globalFlags) -> printVersion + | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalFlags + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ prettyShow cabalVersion + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb + addAction :: CommandUI flags -> (GlobalFlags -> UserHooks -> flags -> [String] -> IO res) -> Command (GlobalFlags -> IO ()) + addAction cmd action = + cmd `commandAddAction` \flags as globalFlags -> void $ action globalFlags hooks flags as + commands :: [Command (GlobalFlags -> IO ())] + commands = + [ configureCommand progs `addAction` configureAction + , buildCommand progs `addAction` buildAction + , replCommand progs `addAction` replAction + , installCommand `addAction` installAction + , copyCommand `addAction` copyAction + , haddockCommand `addAction` haddockAction + , cleanCommand `addAction` cleanAction + , sdistCommand `addAction` sdistAction + , hscolourCommand `addAction` hscolourAction + , registerCommand `addAction` registerAction + , unregisterCommand `addAction` unregisterAction + , testCommand `addAction` testAction + , benchmarkCommand `addAction` benchAction + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers + :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks = + overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction globalFlags hooks flags args = do + distPref <- findDistPrefOrDefault (setupDistPref $ configCommonFlags flags) + let commonFlags = configCommonFlags flags + commonFlags' = + commonFlags + { setupDistPref = toFlag distPref + , setupWorkingDir = globalWorkingDir globalFlags <> setupWorkingDir commonFlags + , setupTargets = args + } + flags' = + flags + { configCommonFlags = commonFlags' + } + mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags' + verbosity = fromFlag $ setupVerbosity commonFlags' + + -- See docs for 'HookedBuildInfo' + pbi <- preConf hooks args flags' + + (mb_pd_file, pkg_descr0) <- + confPkgDescr + hooks + verbosity + mbWorkDir + (flagToMaybe (setupCabalFilePath commonFlags')) + + let epkg_descr = (pkg_descr0, pbi) + + lbi1 <- confHook hooks epkg_descr flags' + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = + lbi1 + { pkgDescrFile = mb_pd_file + , extraConfigArgs = args + } + writePersistBuildConfig mbWorkDir distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + return localbuildinfo + +confPkgDescr + :: UserHooks + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> Maybe (SymbolicPath Pkg File) + -> IO (Maybe (SymbolicPath Pkg File), GenericPackageDescription) +confPkgDescr hooks verbosity cwd mb_path = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- case mb_path of + Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity cwd + Just path -> return path + info verbosity "Using Parsec parser" + descr <- readGenericPackageDescription verbosity cwd pdfile + return (Just pdfile, descr) + +getCommonFlags + :: GlobalFlags + -> UserHooks + -> CommonSetupFlags + -> Args + -> IO (LocalBuildInfo, CommonSetupFlags) +getCommonFlags globalFlags hooks commonFlags args = do + distPref <- findDistPrefOrDefault (setupDistPref commonFlags) + let verbosity = fromFlag $ setupVerbosity commonFlags + lbi <- getBuildConfig globalFlags hooks verbosity distPref + let common' = configCommonFlags $ configFlags lbi + return $ + ( lbi + , commonFlags + { setupDistPref = toFlag distPref + , setupCabalFilePath = setupCabalFilePath common' <> setupCabalFilePath commonFlags + , setupWorkingDir = + globalWorkingDir globalFlags + <> setupWorkingDir common' + <> setupWorkingDir commonFlags + , setupTargets = args + } + ) + +buildAction :: GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO () +buildAction globalFlags hooks flags args = do + let common = buildCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{buildCommonFlags = common'} + + progs <- + reconfigurePrograms + verbosity + (buildProgramPaths flags') + (buildProgramArgs flags') + (withPrograms lbi) + + hookedAction + verbosity + preBuild + buildHook + postBuild + (return lbi{withPrograms = progs}) + hooks + flags' + args + +replAction :: GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO () +replAction globalFlags hooks flags args = do + let common = replCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{replCommonFlags = common'} + progs <- + reconfigurePrograms + verbosity + (replProgramPaths flags') + (replProgramArgs flags') + (withPrograms lbi) + + -- As far as I can tell, the only reason this doesn't use + -- 'hookedActionWithArgs' is because the arguments of 'replHook' + -- takes the args explicitly. UGH. -- ezyang + pbi <- preRepl hooks args flags' + let pkg_descr0 = localPkgDescr lbi + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi' = + lbi + { withPrograms = progs + , localPkgDescr = pkg_descr + } + replHook hooks pkg_descr lbi' hooks flags' args + postRepl hooks args flags' pkg_descr lbi' + +hscolourAction :: GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction globalFlags hooks flags args = do + let common = hscolourCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{hscolourCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + + hookedAction + verbosity + preHscolour + hscolourHook + postHscolour + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +haddockAction :: GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO () +haddockAction globalFlags hooks flags args = do + let common = haddockCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{haddockCommonFlags = common'} + + progs <- + reconfigurePrograms + verbosity + (haddockProgramPaths flags') + (haddockProgramArgs flags') + (withPrograms lbi) + + hookedAction + verbosity + preHaddock + haddockHook + postHaddock + (return lbi{withPrograms = progs}) + hooks + flags' + args + +cleanAction :: GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO () +cleanAction globalFlags hooks flags args = do + let common = cleanCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref <- findDistPrefOrDefault (setupDistPref common) + elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref + let common' = + common + { setupDistPref = toFlag distPref + , setupWorkingDir = case elbi of + Left _ -> + globalWorkingDir globalFlags + <> setupWorkingDir common + Right lbi -> + globalWorkingDir globalFlags + <> setupWorkingDir (configCommonFlags $ configFlags lbi) + <> setupWorkingDir common + , setupCabalFilePath = case elbi of + Left _ -> setupCabalFilePath common + Right lbi -> + setupCabalFilePath common + <> setupCabalFilePath (configCommonFlags $ configFlags lbi) + , setupTargets = args + } + flags' = + flags{cleanCommonFlags = common'} + + mbWorkDirFlag = cleanWorkingDir flags' + mbWorkDir = flagToMaybe mbWorkDirFlag + + pbi <- preClean hooks args flags' + + (_, ppd) <- confPkgDescr hooks verbosity mbWorkDir Nothing + -- It might seem like we are doing something clever here + -- but we're really not: if you look at the implementation + -- of 'clean' in the end all the package description is + -- used for is to clear out @extra-tmp-files@. IMO, + -- the configure script goo should go into @dist@ too! + -- -- ezyang + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + -- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + cleanHook hooks pkg_descr () hooks flags' + postClean hooks args flags' pkg_descr () + +copyAction :: GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO () +copyAction globalFlags hooks flags args = do + let common = copyCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{copyCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preCopy + copyHook + postCopy + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +installAction :: GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO () +installAction globalFlags hooks flags args = do + let common = installCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{installCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preInst + instHook + postInst + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +-- Since Cabal-3.4 UserHooks are completely ignored +sdistAction :: GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO () +sdistAction _globalFlags _hooks flags _args = do + let mbWorkDir = flagToMaybe $ sDistWorkingDir flags + (_, ppd) <- confPkgDescr emptyUserHooks verbosity mbWorkDir Nothing + let pkg_descr = flattenPackageDescription ppd + sdist pkg_descr flags srcPref knownSuffixHandlers + where + verbosity = fromFlag (setupVerbosity $ sDistCommonFlags flags) + +testAction :: GlobalFlags -> UserHooks -> TestFlags -> Args -> IO () +testAction globalFlags hooks flags args = do + let common = testCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{testCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedActionWithArgs + verbosity + preTest + testHook + postTest + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +benchAction :: GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction globalFlags hooks flags args = do + let common = benchmarkCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{benchmarkCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedActionWithArgs + verbosity + preBench + benchHook + postBench + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +registerAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +registerAction globalFlags hooks flags args = do + let common = registerCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{registerCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preReg + regHook + postReg + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +unregisterAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction globalFlags hooks flags args = do + let common = registerCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{registerCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preUnreg + unregHook + postUnreg + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +hookedAction + :: Verbosity + -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> ( UserHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) + -> IO LocalBuildInfo + -> UserHooks + -> flags + -> Args + -> IO () +hookedAction verbosity pre_hook cmd_hook = + hookedActionWithArgs + verbosity + pre_hook + ( \h _ pd lbi uh flags -> + cmd_hook h pd lbi uh flags + ) + +hookedActionWithArgs + :: Verbosity + -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> ( UserHooks + -> Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) + -> IO LocalBuildInfo + -> UserHooks + -> flags + -> Args + -> IO () +hookedActionWithArgs + verbosity + pre_hook + cmd_hook + post_hook + get_build_config + hooks + flags + args = do + pbi <- pre_hook hooks args flags + lbi0 <- get_build_config + let pkg_descr0 = localPkgDescr lbi0 + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi = lbi0{localPkgDescr = pkg_descr} + cmd_hook hooks args pkg_descr lbi hooks flags + post_hook hooks args flags pkg_descr lbi + +sanityCheckHookedBuildInfo + :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo + verbosity + (PackageDescription{library = Nothing}) + (Just _, _) = + dieWithException verbosity $ NoLibraryForPackage +sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) + | exe1 : _ <- nonExistant = + dieWithException verbosity $ SanityCheckHookedBuildInfo exe1 + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames +sanityCheckHookedBuildInfo _ _ _ = return () + +-- | Try to read the 'localBuildInfoFile' +tryGetBuildConfig + :: GlobalFlags + -> UserHooks + -> Verbosity + -> SymbolicPath Pkg (Dir Dist) + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetBuildConfig g u v = try . getBuildConfig g u v + +-- | Read the 'localBuildInfoFile' or throw an exception. +getBuildConfig + :: GlobalFlags + -> UserHooks + -> Verbosity + -> SymbolicPath Pkg (Dir Dist) + -> IO LocalBuildInfo +getBuildConfig globalFlags hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig mbWorkDir distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = + lbi_wo_programs + { withPrograms = + restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + where + mbWorkDir = flagToMaybe $ globalWorkingDir globalFlags + reconfigure :: SymbolicPath Pkg File -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ + getSymbolicPath pkg_descr_file + ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = + cFlags + { -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a configure run: + configPrograms_ = + fmap + ( restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + ) + `fmap` configPrograms_ cFlags + , configCommonFlags = + (configCommonFlags cFlags) + { -- Use the current, not saved verbosity level: + setupVerbosity = Flag verbosity + } + } + configureAction globalFlags hooks cFlags' (extraConfigArgs lbi) + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let common = cleanCommonFlags flags + verbosity = fromFlag (setupVerbosity common) + distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common + mbWorkDir = flagToMaybe $ setupWorkingDir common + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + distPath = i distPref + notice verbosity "cleaning..." + + maybeConfig <- + if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig mbWorkDir distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPath + when exists (removeDirectoryRecursive distPath) + + -- Any extra files the user wants to remove + traverse_ (removeFileOrDirectory . i) (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + traverse_ (writePersistBuildConfig mbWorkDir distPref) maybeConfig + where + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir + then removeDirectoryRecursive fname + else when isFile $ removeFile fname + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks + { confHook = configure + , postConf = finalChecks + , buildHook = defaultBuildHook + , replHook = defaultReplHook + , copyHook = \desc lbi _ f -> install desc lbi f + , -- 'install' has correct 'copy' behavior with params + instHook = defaultInstallHook + , testHook = defaultTestHook + , benchHook = defaultBenchHook + , cleanHook = \p _ _ f -> clean p f + , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f + , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f + , regHook = defaultRegHook + , unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (setupVerbosity $ configCommonFlags flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * 'postConf' runs @.\/configure@, if present. +-- +-- * the pre-hooks, except for pre-conf, read additional build information from +-- /package/@.buildinfo@, if present. +-- +-- Thus @configure@ can use local system information to generate +-- /package/@.buildinfo@ and possibly other files. +autoconfUserHooks :: UserHooks +autoconfUserHooks = + simpleUserHooks + { postConf = defaultPostConf + , preBuild = readHookWithArgs buildCommonFlags + , preRepl = readHookWithArgs replCommonFlags + , preCopy = readHookWithArgs copyCommonFlags + , preClean = readHook cleanCommonFlags + , preInst = readHook installCommonFlags + , preHscolour = readHook hscolourCommonFlags + , preHaddock = readHookWithArgs haddockCommonFlags + , preReg = readHook registerCommonFlags + , preUnreg = readHook registerCommonFlags + , preTest = readHookWithArgs testCommonFlags + , preBench = readHookWithArgs benchmarkCommonFlags + } + where + defaultPostConf + :: Args + -> ConfigFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () + defaultPostConf args flags pkg_descr lbi = + do + let common = configCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + runConfigureScript + flags + (flagAssignment lbi) + (withPrograms lbi) + (hostPlatform lbi) + pbi <- getHookedBuildInfo verbosity mbWorkDir (buildDir lbi) + sanityCheckHookedBuildInfo verbosity pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + lbi' = lbi{localPkgDescr = pkg_descr'} + postConf simpleUserHooks args flags pkg_descr' lbi' + + readHookWithArgs + :: (flags -> CommonSetupFlags) + -> Args + -> flags + -> IO HookedBuildInfo + readHookWithArgs get_common_flags _args flags = do + let common = get_common_flags flags + verbosity = fromFlag (setupVerbosity common) + mbWorkDir = flagToMaybe $ setupWorkingDir common + distPref = setupDistPref common + dist_dir <- findDistPrefOrDefault distPref + getHookedBuildInfo verbosity mbWorkDir (dist_dir makeRelativePathEx "build") + + readHook + :: (flags -> CommonSetupFlags) + -> Args + -> flags + -> IO HookedBuildInfo + readHook get_common_flags args flags = do + let common = get_common_flags flags + verbosity = fromFlag (setupVerbosity common) + mbWorkDir = flagToMaybe $ setupWorkingDir common + distPref = setupDistPref common + noExtraFlags args + dist_dir <- findDistPrefOrDefault distPref + getHookedBuildInfo verbosity mbWorkDir (dist_dir makeRelativePathEx "build") + +getHookedBuildInfo + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Build) + -> IO HookedBuildInfo +getHookedBuildInfo verbosity mbWorkDir build_dir = do + maybe_infoFile <- findHookedPackageDesc verbosity mbWorkDir build_dir + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ getSymbolicPath infoFile + readHookedBuildInfo verbosity mbWorkDir infoFile + +autoconfSetupHooks :: SetupHooks +autoconfSetupHooks = + SetupHooks.noSetupHooks + { SetupHooks.configureHooks = + SetupHooks.noConfigureHooks + { SetupHooks.postConfPackageHook = Just post_conf_pkg + , SetupHooks.preConfComponentHook = Just pre_conf_comp + } + } + where + post_conf_pkg + :: SetupHooks.PostConfPackageInputs + -> IO () + post_conf_pkg + ( SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = + LBC.LocalBuildConfig{LBC.withPrograms = progs} + , SetupHooks.packageBuildDescr = + LBC.PackageBuildDescr + { LBC.configFlags = cfg + , LBC.flagAssignment = flags + , LBC.hostPlatform = plat + } + } + ) = runConfigureScript cfg flags progs plat + + pre_conf_comp + :: SetupHooks.PreConfComponentInputs + -> IO SetupHooks.PreConfComponentOutputs + pre_conf_comp + ( SetupHooks.PreConfComponentInputs + { SetupHooks.packageBuildDescr = + LBC.PackageBuildDescr + { LBC.configFlags = cfg + , localPkgDescr = pkg_descr + } + , SetupHooks.component = component + } + ) = do + let verbosity = fromFlag $ configVerbosity cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + distPref = configDistPref cfg + dist_dir <- findDistPrefOrDefault distPref + -- Read the ".buildinfo" file and use that to update + -- the components (main library + executables only). + hbi <- getHookedBuildInfo verbosity mbWorkDir (dist_dir makeRelativePathEx "build") + sanityCheckHookedBuildInfo verbosity pkg_descr hbi + -- SetupHooks TODO: we are reading getHookedBuildInfo once + -- for each component. I think this is inherent to the SetupHooks + -- approach. + let comp_name = componentName component + diff <- case SetupHooks.hookedBuildInfoComponentDiff_maybe hbi comp_name of + Nothing -> return $ SetupHooks.emptyComponentDiff comp_name + Just do_diff -> do_diff + return $ + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } + +defaultTestHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> TestFlags + -> IO () +defaultTestHook args pkg_descr localbuildinfo _ flags = + test args pkg_descr localbuildinfo flags + +defaultBenchHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BenchmarkFlags + -> IO () +defaultBenchHook args pkg_descr localbuildinfo _ flags = + bench args pkg_descr localbuildinfo flags + +defaultInstallHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () +defaultInstallHook = + defaultInstallHook_setupHooks SetupHooks.noInstallHooks + +defaultInstallHook_setupHooks + :: SetupHooks.InstallHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () +defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do + let copyFlags = + defaultCopyFlags + { copyDest = installDest flags + , copyCommonFlags = installCommonFlags flags + } + install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags + let registerFlags = + defaultRegisterFlags + { regInPlace = installInPlace flags + , regPackageDB = installPackageDB flags + , registerCommonFlags = installCommonFlags flags + } + when (hasLibs pkg_descr) $ + register pkg_descr localbuildinfo registerFlags + +defaultBuildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultReplHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () +defaultReplHook pkg_descr localbuildinfo hooks flags args = + repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args + +defaultRegHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> RegisterFlags + -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else + setupMessage + (fromFlag (setupVerbosity $ registerCommonFlags flags)) + "Package contains no library to register:" + (packageId pkg_descr) diff --git a/src/Distribution/Simple/Bench.hs b/src/Distribution/Simple/Bench.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Bench.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Bench +-- Copyright : Johan Tibell 2011 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into running the benchmarks in a built +-- package. It performs the \"@.\/setup bench@\" action. It runs +-- benchmarks designated in the package description. +module Distribution.Simple.Bench + ( bench + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build (addInternalBuildTools) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Setup.Benchmark +import Distribution.Simple.Setup.Common +import Distribution.Simple.UserHooks +import Distribution.Simple.Utils +import Distribution.System (Platform (Platform)) +import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) +import Distribution.Types.UnqualComponentName +import Distribution.Utils.Path + +import System.Directory (doesFileExist) + +-- | Perform the \"@.\/setup bench@\" action. +bench + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> BenchmarkFlags + -- ^ flags sent to benchmark + -> IO () +bench args pkg_descr lbi flags = do + curDir <- LBI.absoluteWorkingDirLBI lbi + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi + mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + + -- Run the benchmark + doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode + doBench (bm, clbi) = do + let lbiForBench = + lbi + { -- Include any build-tool-depends on build tools internal to the current package. + LBI.withPrograms = + addInternalBuildTools + curDir + pkg_descr + lbi + (benchmarkBuildInfo bm) + (LBI.withPrograms lbi) + } + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = i $ LBI.buildDir lbiForBench makeRelativePathEx (name name <.> exeExtension (LBI.hostPlatform lbi)) + options = + map (benchOption pkg_descr lbiForBench bm) $ + benchmarkOptions flags + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + NoBenchMarkProgram cmd + + -- Compute the appropriate environment for running the benchmark + let progDb = LBI.withPrograms lbiForBench + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar + shellEnv <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides) + + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbiForBench + then do + let (Platform _ os) = LBI.hostPlatform lbiForBench + paths <- LBI.depLibraryPaths True False lbiForBench clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv + + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options (Just shellEnv') + notice verbosity $ finishMessage name exitcode + return exitcode + _ -> do + notice verbosity $ + "No support for running " + ++ "benchmark " + ++ name + ++ " of type: " + ++ prettyShow (PD.benchmarkType bm) + exitFailure + where + name = unUnqualComponentName $ PD.benchmarkName bm + + unless (PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitSuccess + + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + dieWithException verbosity EnableBenchMark + + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> for names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup (mkUnqualComponentName bmName) benchmarkMap of + Just t -> return t + _ + | mkUnqualComponentName bmName `elem` allNames -> + dieWithException verbosity $ BenchMarkNameDisabled bmName + | otherwise -> dieWithException verbosity $ NoBenchMark bmName + + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- traverse doBench bmsToRun + + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure + where + startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" + finishMessage name exitcode = + "Benchmark " + ++ name + ++ ": " + ++ ( case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR" + ) + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +benchOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String +benchOption pkg_descr lbi bm template = + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] diff --git a/src/Distribution/Simple/Build.hs b/src/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build.hs @@ -0,0 +1,1240 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008, 2012 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +module Distribution.Simple.Build + ( -- * Build + build + , build_setupHooks + + -- * Repl + , repl + , repl_setupHooks + , startInterpreter + + -- * Build preparation + , preBuildComponent + , AutogenFile (..) + , AutogenFileContents + , writeBuiltinAutogenFiles + , writeAutogenFiles + + -- ** Legacy functions + , componentInitialBuildSteps + , initialBuildSteps + + -- * Internal package database creation + , createInternalPackageDB + + -- * Handling of internal build tools + , addInternalBuildTools + ) where + +import Distribution.Compat.Prelude +import Distribution.Utils.Generic +import Prelude () + +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Dependency +import Distribution.Types.ExecutableScope +import Distribution.Types.ForeignLib +import Distribution.Types.LibraryVisibility +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo +import Distribution.Utils.Path + +import Distribution.Backpack +import Distribution.Backpack.DescribeUnitId +import Distribution.Package +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC + +import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) +import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule) +import Distribution.Simple.Build.PathsModule (generatePathsModule, pkgPathEnvVar) +import qualified Distribution.Simple.Program.HcPkg as HcPkg + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Simple.Compiler + +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Configure +import Distribution.Simple.Flag +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import qualified Distribution.Simple.Program.GHC as GHC +import Distribution.Simple.Program.Types +import Distribution.Simple.Register +import Distribution.Simple.Setup.Build +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Repl +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , BuildingWhat (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks +import Distribution.Simple.ShowBuildInfo +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.Utils.Json +import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) + +import Distribution.Pretty +import Distribution.System +import Distribution.Verbosity +import Distribution.Version (thisVersion) + +import Distribution.Compat.Graph (IsNode (..)) + +import Control.Monad +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import Distribution.Simple.Errors +import System.Directory (doesFileExist, removeFile) +import System.FilePath (takeDirectory) + +-- ----------------------------------------------------------------------------- + +-- | Build the libraries and executables in this package. +build + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build = build_setupHooks noBuildHooks + +build_setupHooks + :: BuildHooks + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild}) + pkg_descr + lbi + flags + suffixHandlers = do + checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) + + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + curDir <- absoluteWorkingDirLBI lbi + + -- Now do the actual building + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + let comp = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo comp + -- Include any build-tool-depends on build tools internal to the current package. + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildNormal flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi' target + let numJobs = buildNumJobs flags + par_strat <- + toFlag <$> case buildUseSemaphore flags of + Flag sem_name -> case numJobs of + Flag{} -> do + warn verbosity $ "Ignoring -j due to --semaphore" + return $ UseSem sem_name + NoFlag -> return $ UseSem sem_name + NoFlag -> return $ case numJobs of + Flag n -> NumJobs n + NoFlag -> Serial + mb_ipi <- + buildComponent + flags + par_strat + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + let postBuildInputs = + SetupHooks.PostBuildComponentInputs + { SetupHooks.buildFlags = flags + , SetupHooks.localBuildInfo = lbi' + , SetupHooks.targetInfo = target + } + for_ mbPostBuild ($ postBuildInputs) + return (maybe index (Index.insert `flip` index) mb_ipi) + + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + +-- | Check for conditions that would prevent the build from succeeding. +checkSemaphoreSupport + :: Verbosity -> Compiler -> BuildFlags -> IO () +checkSemaphoreSupport verbosity comp flags = do + unless (jsemSupported comp || (isNothing (flagToMaybe (buildUseSemaphore flags)))) $ + dieWithException verbosity CheckSemaphoreSupport + +-- | Write available build information for 'LocalBuildInfo' to disk. +-- +-- Dumps detailed build information 'build-info.json' to the given directory. +-- Build information contains basics such as compiler details, but also +-- lists what modules a component contains and how to compile the component, assuming +-- lib:Cabal made sure that dependencies are up-to-date. +dumpBuildInfo + :: Verbosity + -> SymbolicPath Pkg (Dir Dist) + -- ^ To which directory should the build-info be dumped? + -> Flag DumpBuildInfo + -- ^ Should we dump detailed build information for this component? + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> IO () +dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do + when shouldDumpBuildInfo $ do + -- Changing this line might break consumers of the dumped build info. + -- Announce changes on mailing lists! + let activeTargets = allTargetsInBuildOrder' pkg_descr lbi + info verbosity $ + "Dump build information for: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + activeTargets + ) + + (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of + Nothing -> + dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi)) + Just program -> requireProgram verbosity program (withPrograms lbi) + + wdir <- absoluteWorkingDirLBI lbi + let (warns, json) = mkBuildInfo wdir pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets + buildInfoText = renderJson json + unless (null warns) $ + warn verbosity $ + "Encountered warnings while dumping build-info:\n" + ++ unlines warns + LBS.writeFile buildInfoFile buildInfoText + + when (not shouldDumpBuildInfo) $ do + -- Remove existing build-info.json as it might be outdated now. + exists <- doesFileExist buildInfoFile + when exists $ removeFile buildInfoFile + where + buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref + shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo + + -- \| Given the flavor of the compiler, try to find out + -- which program we need. + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram _ = Nothing + +repl + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl = repl_setupHooks noBuildHooks + +repl_setupHooks + :: BuildHooks + -- ^ build hook + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + flags + suffixHandlers + args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + target <- + readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target : _) -> return target + [] -> dieWithException verbosity $ FailedToDetermineTarget + [target] -> return target + _ -> dieWithException verbosity $ NoMultipleTargets + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] + debug verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = do + curDir <- absoluteWorkingDirLBI lbi' + return $ + lbi' + { withPackageDB = withPackageDB lbi' ++ [internalPackageDB] + , withPrograms = + -- Include any build-tool-depends on build tools internal to the current package. + addInternalBuildTools + curDir + pkg_descr + lbi' + (componentBuildInfo comp) + (withPrograms lbi') + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildRepl flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + + -- build any dependent components + sequence_ + [ do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' <- lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' subtarget + buildComponent + (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) + NoFlag + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + | subtarget <- safeInit componentsToBuild + ] + + -- REPL for target components + let clbi = targetCLBI target + comp = targetComponent target + lbi' <- lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' target + replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref + +-- | Start an interpreter without loading any package files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity programDb comp platform packageDBs = + case compilerFlavor comp of + GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs + GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs + _ -> dieWithException verbosity REPLNotSupported + +buildComponent + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> IO (Maybe InstalledPackageInfo) +buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ + NoSupportBuildingTestSuite tt +buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ + NoSupportBuildingBenchMark tt +buildComponent + flags + numJobs + pkg_descr + lbi0 + suffixHandlers + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = + do + inplaceDir <- absoluteWorkingDirLBI lbi0 + let verbosity = fromFlag $ buildVerbosity flags + let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} + buildLib flags numJobs pkg lbi lib' libClbi + -- NB: need to enable multiple instances here, because on 7.10+ + -- the package name is the same as the library, and we still + -- want the registration to go through. + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (mbWorkDirLBI lbi) + (withPackageDB lbi) + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + let ebi = buildInfo exe + -- NB: The stub executable is linked against the test-library + -- which already contains all `other-modules`, so we need + -- to remove those from the stub-exe's build-info + exe' = exe{buildInfo = (addExtraCSources ebi extras){otherModules = []}} + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi + return Nothing -- Can't depend on test suite +buildComponent + flags + numJobs + pkg_descr + lbi + suffixHandlers + comp + clbi + distPref = + do + let verbosity = fromFlag $ buildVerbosity flags + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + case comp of + CLib lib -> do + let libbi = libBuildInfo lib + lib' = + lib + { libBuildInfo = + flip addExtraAsmSources extras $ + flip addExtraCmmSources extras $ + flip addExtraCxxSources extras $ + flip addExtraCSources extras $ + flip addExtraJsSources extras $ + libbi + } + + buildLib flags numJobs pkg_descr lbi lib' clbi + + let oneComponentRequested (OneComponentRequestedSpec _) = True + oneComponentRequested _ = False + -- Don't register inplace if we're only building a single component; + -- it's not necessary because there won't be any subsequent builds + -- that need to tag us + if (not (oneComponentRequested (componentEnabledSpec lbi))) + then do + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + inplaceDir <- absoluteWorkingDirLBI lbi + let + -- The in place registration uses the "-inplace" suffix, not an ABI hash + installedPkgInfo = + inplaceInstalledPackageInfo + inplaceDir + distPref + pkg_descr + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") + lib' + lbi + clbi + debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (flagToMaybe $ buildWorkingDir flags) + (withPackageDB lbi) + installedPkgInfo + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + return (Just installedPkgInfo) + else return Nothing + CFLib flib -> do + buildFLib verbosity numJobs pkg_descr lbi flib clbi + return Nothing + CExe exe -> do + let ebi = buildInfo exe + exe' = exe{buildInfo = addExtraCSources ebi extras} + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do + let exe = testSuiteExeV10AsExe test + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + let ebi = buildInfo exe + exe' = exe{buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir} -- todo extend hssrcdirs + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do + let exe = benchmarkExeV10asExe bm + let ebi = buildInfo exe + exe' = exe{buildInfo = addExtraCSources ebi extras} + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing +#if __GLASGOW_HASKELL__ < 811 +-- silence pattern-match warnings prior to GHC 9.0 + _ -> error "impossible" +#endif + +generateCode + :: [String] + -> UnqualComponentName + -> PackageDescription + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Verbosity + -> IO (SymbolicPath Pkg (Dir Source), [ModuleName.ModuleName]) +generateCode codeGens nm pdesc bi lbi clbi verbosity = do + when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir + (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + where + allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) + dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi + srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs + nm' = unUnqualComponentName nm + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + tgtDir = buildDir lbi makeRelativePathEx (nm' nm' ++ "-gen") + go :: String -> IO [ModuleName.ModuleName] + go codeGenProg = + fmap fromString . lines + <$> getDbProgramOutputCwd + verbosity + mbWorkDir + (simpleProgram codeGenProg) + (withPrograms lbi) + ( map interpretSymbolicPathCWD (tgtDir : srcDirs) + ++ ( "--" + : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir) + ) + ) + +-- | Add extra C sources generated by preprocessing to build +-- information. +addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraCSources bi extras = bi{cSources = new} + where + new = ordNub (extras ++ cSources bi) + +-- | Add extra C++ sources generated by preprocessing to build +-- information. +addExtraCxxSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraCxxSources bi extras = bi{cxxSources = new} + where + new = ordNub (extras ++ cxxSources bi) + +-- | Add extra C-- sources generated by preprocessing to build +-- information. +addExtraCmmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraCmmSources bi extras = bi{cmmSources = new} + where + new = ordNub (extras ++ cmmSources bi) + +-- | Add extra ASM sources generated by preprocessing to build +-- information. +addExtraAsmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraAsmSources bi extras = bi{asmSources = new} + where + new = ordNub (extras ++ asmSources bi) + +-- | Add extra JS sources generated by preprocessing to build +-- information. +addExtraJsSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraJsSources bi extras = bi{jsSources = new} + where + new = ordNub (extras ++ jsSources bi) + +-- | Add extra HS modules generated by preprocessing to build +-- information. +addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo +addExtraOtherModules bi extras = bi{otherModules = new} + where + new = ordNub (extras ++ otherModules bi) + +-- | Add extra source dir for generated modules. +addSrcDir :: BuildInfo -> SymbolicPath Pkg (Dir Source) -> BuildInfo +addSrcDir bi extra = bi{hsSourceDirs = new} + where + new = ordNub (extra : hsSourceDirs bi) + +replComponent + :: ReplFlags + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> IO () +replComponent _ verbosity _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException verbosity $ NoSupportBuildingTestSuite tt +replComponent _ verbosity _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException verbosity $ NoSupportBuildingBenchMark tt +replComponent + replFlags + verbosity + pkg_descr + lbi0 + suffixHandlers + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi + distPref = do + inplaceDir <- absoluteWorkingDirLBI lbi0 + let (pkg, lib, libClbi, lbi, _, _, _) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + replLib replFlags pkg lbi lib' libClbi +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixHandlers + comp + clbi + _ = + do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi + case comp of + CLib lib -> do + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + replLib replFlags pkg_descr lbi lib' clbi + CFLib flib -> + replFLib replFlags pkg_descr lbi flib clbi + CExe exe -> do + let ebi = buildInfo exe + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + replExe replFlags pkg_descr lbi exe' clbi + CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do + let exe = testSuiteExeV10AsExe test + let ebi = buildInfo exe + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + replExe replFlags pkg_descr lbi exe' clbi + CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do + let exe = benchmarkExeV10asExe bm + let ebi = buildInfo exe + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + replExe replFlags pkg_descr lbi exe' clbi +#if __GLASGOW_HASKELL__ < 811 +-- silence pattern-match warnings prior to GHC 9.0 + _ -> error "impossible" +#endif + +---------------------------------------------------- +-- Shared code for buildComponent and replComponent +-- + +-- | Translate a exe-style 'TestSuite' component into an exe for building +testSuiteExeV10AsExe :: TestSuite -> Executable +testSuiteExeV10AsExe test@TestSuite{testInterface = TestSuiteExeV10 _ mainFile} = + Executable + { exeName = testName test + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } +testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" + +-- | Translate a exe-style 'Benchmark' component into an exe for building +benchmarkExeV10asExe :: Benchmark -> Executable +benchmarkExeV10asExe bm@Benchmark{benchmarkInterface = BenchmarkExeV10 _ mainFile} = + Executable + { exeName = benchmarkName bm + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bm + } +benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" + +-- | Translate a lib-style 'TestSuite' component into a lib + exe for building +testSuiteLibV09AsLibAndExe + :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> AbsolutePath (Dir Pkg) + -- ^ absolute inplace dir + -> SymbolicPath Pkg (Dir Dist) + -> ( PackageDescription + , Library + , ComponentLocalBuildInfo + , LocalBuildInfo + , IPI.InstalledPackageInfo + , Executable + , ComponentLocalBuildInfo + ) +testSuiteLibV09AsLibAndExe + pkg_descr + test@TestSuite{testInterface = TestSuiteLibV09 _ m} + clbi + lbi + inplaceDir + distPref = + (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) + where + bi = testBuildInfo test + lib = + Library + { libName = LMainLibName + , exposedModules = [m] + , reexportedModules = [] + , signatures = [] + , libExposed = True + , libVisibility = LibraryVisibilityPrivate + , libBuildInfo = bi + } + -- This is, like, the one place where we use a CTestName for a library. + -- Should NOT use library name, since that could conflict! + PackageIdentifier pkg_name pkg_ver = package pkg_descr + -- Note: we do make internal library from the test! + compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) + compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) + libClbi = + LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False + , componentExeDeps = componentExeDeps clbi + , componentLocalName = CLibName $ LSubLibName $ testName test + , componentIsPublic = False + , componentIncludes = componentIncludes clbi + , componentUnitId = componentUnitId clbi + , componentComponentId = componentComponentId clbi + , componentInstantiatedWith = [] + , componentCompatPackageName = compat_name + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] + } + pkgName' = mkPackageName $ prettyShow compat_name + pkg = + pkg_descr + { package = (package pkg_descr){pkgName = pkgName'} + , executables = [] + , testSuites = [] + , subLibraries = [lib] + } + ipi = inplaceInstalledPackageInfo inplaceDir distPref pkg (mkAbiHash "") lib lbi libClbi + testLibDep = + Dependency + pkgName' + (thisVersion $ pkgVersion $ package pkg_descr) + mainLibSet + exe = + Executable + { exeName = mkUnqualComponentName $ stubName test + , modulePath = makeRelativePathEx $ stubFilePath test + , exeScope = ExecutablePublic + , buildInfo = + (testBuildInfo test) + { hsSourceDirs = [coerceSymbolicPath $ testBuildDir lbi test] + , targetBuildDepends = + testLibDep + : targetBuildDepends (testBuildInfo test) + } + } + -- \| The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + deps = + (IPI.installedUnitId ipi, mungedId ipi) + : ( filter + ( \(_, x) -> + let name = prettyShow $ mungedName x + in name == "Cabal" || name == "base" + ) + (componentPackageDeps clbi) + ) + exeClbi = + ExeComponentLocalBuildInfo + { -- TODO: this is a hack, but as long as this is unique + -- (doesn't clobber something) we won't run into trouble + componentUnitId = mkUnitId (stubName test) + , componentComponentId = mkComponentId (stubName test) + , componentInternalDeps = [componentUnitId clbi] + , componentExeDeps = [] + , componentLocalName = CExeName $ mkUnqualComponentName $ stubName test + , componentPackageDeps = deps + , -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = + map ((,defaultRenaming) . DefiniteUnitId . unsafeMkDefUnitId . fst) deps + } +testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB + :: Verbosity + -> LocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> IO PackageDB +createInternalPackageDB verbosity lbi distPref = do + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbRelPath) + where + dbRelPath = internalPackageDBPath lbi distPref + dbPath = interpretSymbolicPathLBI lbi dbRelPath + +-- | Update the program database to include any build-tool-depends specified +-- in the given 'BuildInfo' on build tools internal to the current package. +-- +-- This function: +-- +-- - adds these internal build tools to the 'ProgramDb', including +-- paths to their respective data directories, +-- - adds their paths to the current 'progSearchPath', and adds the data +-- directory environment variable for the current package to the current +-- 'progOverrideEnv', so that any programs configured from now on will be +-- able to invoke these build tools. +addInternalBuildTools + :: AbsolutePath (Dir Pkg) + -> PackageDescription + -> LocalBuildInfo + -> BuildInfo + -> ProgramDb + -> ProgramDb +addInternalBuildTools pwd pkg lbi bi progs = + prependProgramSearchPathNoLogging + internalToolPaths + [pkgDataDirVar] + $ foldr updateProgram progs internalBuildTools + where + internalToolPaths = map (takeDirectory . programPath) internalBuildTools + pkgDataDirVar = (pkgPathEnvVar pkg "datadir", Just dataDirPath) + internalBuildTools = + [ (simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)) + { programOverrideEnv = [pkgDataDirVar] + } + | toolName <- getAllInternalToolDependencies pkg bi + , let toolName' = unUnqualComponentName toolName + , let toolLocation = + interpretSymbolicPathLBI lbi $ + buildDir lbi + makeRelativePathEx (toolName' toolName' <.> exeExtension (hostPlatform lbi)) + ] + + -- This is an absolute path, so if a process changes directory, it can still + -- find the datadir (#10717) + dataDirPath :: FilePath + dataDirPath = interpretSymbolicPathAbsolute pwd (dataDir pkg) + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style test suites +buildLib + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib flags numJobs pkg_descr lbi lib clbi = + let verbosity = fromFlag $ buildVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +-- | Build a foreign library +-- +-- NOTE: We assume that we already checked that we can actually build the +-- foreign library in configure. +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib verbosity numJobs pkg_descr lbi flib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe verbosity numJobs pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +replLib + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib replFlags pkg_descr lbi lib clbi = + let verbosity = fromFlag $ replVerbosity replFlags + opts = replReplOptions replFlags + in case compilerFlavor (compiler lbi) of + -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass + -- NoFlag as the numJobs parameter. + GHC -> GHC.replLib replFlags NoFlag pkg_descr lbi lib clbi + GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi + _ -> dieWithException verbosity REPLNotSupported + +replExe + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi + GHCJS -> + GHCJS.replExe + (replOptionsFlags $ replReplOptions flags) + verbosity + NoFlag + pkg_descr + lbi + exe + clbi + _ -> dieWithException verbosity REPLNotSupported + +replFLib + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi + _ -> dieWithException verbosity REPLNotSupported + +-- | Runs 'componentInitialBuildSteps' on every configured component. +-- +-- Legacy function: does not run pre-build hooks or pre-processors. This function +-- is insufficient on its own to prepare the build for a package. +-- +-- Consumers wanting to prepare the sources of a package, e.g. in order to +-- launch a REPL session, are advised to run @Setup repl --repl-multi-file=@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/Macros.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > VERSION_ +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +-- TODO Figure out what to do about backpack and internal libraries. It is very +-- suspicious that this stuff works with munged package identifiers +module Distribution.Simple.Build.Macros + ( generateCabalMacrosHeader + , generatePackageVersionMacros + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Types +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Version + +import qualified Distribution.Simple.Build.Macros.Z as Z + +-- | The contents of the @cabal_macros.h@ for the given configured package. +generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String +generateCabalMacrosHeader pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) + , Z.zTools = + [ Z.ZTool + { Z.ztoolName = programId prog + , Z.ztoolVersion = ver + , Z.ztoolX = major1 + , Z.ztoolY = major2 + , Z.ztoolZ = minor + } + | prog <- configuredPrograms $ withPrograms lbi + , ver <- maybeToList (programVersion prog) + , let (major1, major2, minor) = majorMinor ver + ] + , Z.zPackageKey = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey + _ -> "" + , Z.zComponentId = prettyShow (componentComponentId clbi) + , Z.zPackageVersion = pkgVersion (package pkg_descr) + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } + where + getPid (_, MungedPackageId (MungedPackageName pn _) v) = + -- NB: Drop the library name! We're just reporting package versions. + -- This would have to be revisited if you are allowed to depend + -- on different versions of the same package + PackageIdentifier pn v + +-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ +-- macros for a list of package ids (usually used with the specific deps of +-- a configured package). +generatePackageVersionMacros :: Version -> [PackageId] -> String +generatePackageVersionMacros ver pkgids = + Z.render + Z.Z + { Z.zPackages = map mkZPackage pkgids + , Z.zTools = [] + , Z.zPackageKey = "" + , Z.zComponentId = "" + , Z.zPackageVersion = ver + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } + +mkZPackage :: PackageId -> Z.ZPackage +mkZPackage (PackageIdentifier name ver) = + Z.ZPackage + { Z.zpkgName = name + , Z.zpkgVersion = ver + , Z.zpkgX = major1 + , Z.zpkgY = major2 + , Z.zpkgZ = minor + } + where + (major1, major2, minor) = majorMinor ver + +majorMinor :: Version -> (String, String, String) +majorMinor ver = case map show (versionNumbers ver) of + [] -> ("0", "0", "0") + [x] -> (x, "0", "0") + [x, y] -> (x, y, "0") + (x : y : z : _) -> (x, y, z) + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c diff --git a/src/Distribution/Simple/Build/Macros/Z.hs b/src/Distribution/Simple/Build/Macros/Z.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/Macros/Z.hs @@ -0,0 +1,141 @@ +{- FOURMOLU_DISABLE -} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Simple.Build.Macros.Z (render, Z(..), ZPackage (..), ZTool (..)) where +import Distribution.ZinzaPrelude +data Z + = Z {zPackages :: [ZPackage], + zTools :: [ZTool], + zPackageKey :: String, + zComponentId :: String, + zPackageVersion :: Version, + zNotNull :: (String -> Bool), + zManglePkgName :: (PackageName -> String), + zMangleStr :: (String -> String)} + deriving Generic +data ZPackage + = ZPackage {zpkgName :: PackageName, + zpkgVersion :: Version, + zpkgX :: String, + zpkgY :: String, + zpkgZ :: String} + deriving Generic +data ZTool + = ZTool {ztoolName :: String, + ztoolVersion :: Version, + ztoolX :: String, + ztoolY :: String, + ztoolZ :: String} + deriving Generic +render :: Z -> String +render z_root = execWriter $ do + tell "/* DO NOT EDIT: This file is automatically generated by Cabal */\n" + tell "\n" + forM_ (zPackages z_root) $ \z_var0_pkg -> do + tell "/* package " + tell (prettyShow (zpkgName z_var0_pkg)) + tell "-" + tell (prettyShow (zpkgVersion z_var0_pkg)) + tell " */\n" + tell "#ifndef VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell "\n" + tell "#define VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell " \"" + tell (prettyShow (zpkgVersion z_var0_pkg)) + tell "\"\n" + tell "#endif /* VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell " */\n" + tell "#ifndef MIN_VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell "\n" + tell "#define MIN_VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell "(major1,major2,minor) (\\\n" + tell " (major1) < " + tell (zpkgX z_var0_pkg) + tell " || \\\n" + tell " (major1) == " + tell (zpkgX z_var0_pkg) + tell " && (major2) < " + tell (zpkgY z_var0_pkg) + tell " || \\\n" + tell " (major1) == " + tell (zpkgX z_var0_pkg) + tell " && (major2) == " + tell (zpkgY z_var0_pkg) + tell " && (minor) <= " + tell (zpkgZ z_var0_pkg) + tell ")\n" + tell "#endif /* MIN_VERSION_" + tell (zManglePkgName z_root (zpkgName z_var0_pkg)) + tell " */\n" + tell "\n" + forM_ (zTools z_root) $ \z_var1_tool -> do + tell "/* tool " + tell (ztoolName z_var1_tool) + tell "-" + tell (prettyShow (ztoolVersion z_var1_tool)) + tell " */\n" + tell "#ifndef TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell "\n" + tell "#define TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell " \"" + tell (prettyShow (ztoolVersion z_var1_tool)) + tell "\"\n" + tell "#endif /* TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell " */\n" + tell "#ifndef MIN_TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell "\n" + tell "#define MIN_TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell "(major1,major2,minor) (\\\n" + tell " (major1) < " + tell (ztoolX z_var1_tool) + tell " || \\\n" + tell " (major1) == " + tell (ztoolX z_var1_tool) + tell " && (major2) < " + tell (ztoolY z_var1_tool) + tell " || \\\n" + tell " (major1) == " + tell (ztoolX z_var1_tool) + tell " && (major2) == " + tell (ztoolY z_var1_tool) + tell " && (minor) <= " + tell (ztoolZ z_var1_tool) + tell ")\n" + tell "#endif /* MIN_TOOL_VERSION_" + tell (zMangleStr z_root (ztoolName z_var1_tool)) + tell " */\n" + tell "\n" + if (zNotNull z_root (zPackageKey z_root)) + then do + tell "#ifndef CURRENT_PACKAGE_KEY\n" + tell "#define CURRENT_PACKAGE_KEY \"" + tell (zPackageKey z_root) + tell "\"\n" + tell "#endif /* CURRENT_packageKey */\n" + return () + else do + return () + if (zNotNull z_root (zComponentId z_root)) + then do + tell "#ifndef CURRENT_COMPONENT_ID\n" + tell "#define CURRENT_COMPONENT_ID \"" + tell (zComponentId z_root) + tell "\"\n" + tell "#endif /* CURRENT_COMPONENT_ID */\n" + return () + else do + return () + tell "#ifndef CURRENT_PACKAGE_VERSION\n" + tell "#define CURRENT_PACKAGE_VERSION \"" + tell (prettyShow (zPackageVersion z_root)) + tell "\"\n" + tell "#endif /* CURRENT_PACKAGE_VERSION */\n" 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/PathsModule.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +module Distribution.Simple.Build.PathsModule + ( generatePathsModule + , pkgPathEnvVar + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils (shortRelativePath) +import Distribution.System +import Distribution.Version + +import qualified Distribution.Simple.Build.PathsModule.Z as Z + +-- ------------------------------------------------------------ + +-- * Building Paths_.hs + +-- ------------------------------------------------------------ + +generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String +generatePathsModule pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackageName = packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , Z.zSupportsCpp = supports_cpp + , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax + , Z.zAbsolute = absolute + , Z.zRelocatable = relocatable lbi + , Z.zIsWindows = isWindows + , Z.zIsI386 = buildArch == I386 + , Z.zIsX8664 = buildArch == X86_64 + , Z.zIsAArch64 = buildArch == AArch64 + , Z.zNot = not + , Z.zManglePkgName = showPkgName + , Z.zPrefix = show flat_prefix + , Z.zBindir = zBindir + , Z.zLibdir = zLibdir + , Z.zDynlibdir = zDynlibdir + , Z.zDatadir = zDatadir + , Z.zLibexecdir = zLibexecdir + , Z.zSysconfdir = zSysconfdir + } + where + supports_cpp = supports_language_pragma + supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1]) + supports_language_pragma = ghc_newer_than (mkVersion [6, 6, 1]) + + ghc_newer_than minVersion = + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion + + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform + isWindows = case buildOS of + Windows -> True + _ -> False + + supportsRelocatableProgs GHC = isWindows + supportsRelocatableProgs GHCJS = isWindows + supportsRelocatableProgs _ = False + + cid = componentUnitId clbi + + InstallDirs + { bindir = flat_bindir + , libdir = flat_libdir + , dynlibdir = flat_dynlibdir + , datadir = flat_datadir + , libexecdir = flat_libexecdir + , sysconfdir = flat_sysconfdir + , prefix = flat_prefix + } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest + + InstallDirs + { bindir = flat_bindirrel + , libdir = flat_libdirrel + , dynlibdir = flat_dynlibdirrel + , datadir = flat_datadirrel + , libexecdir = flat_libexecdirrel + , sysconfdir = flat_sysconfdirrel + } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid + + zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String + (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir) + | relocatable lbi = + ( show flat_bindir_reloc + , show flat_libdir_reloc + , show flat_dynlibdir_reloc + , show flat_datadir_reloc + , show flat_libexecdir_reloc + , show flat_sysconfdir_reloc + ) + | absolute = + ( show flat_bindir + , show flat_libdir + , show flat_dynlibdir + , show flat_datadir + , show flat_libexecdir + , show flat_sysconfdir + ) + | isWindows = + ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" + , mkGetDir flat_libdir flat_libdirrel + , mkGetDir flat_dynlibdir flat_dynlibdirrel + , mkGetDir flat_datadir flat_datadirrel + , mkGetDir flat_libexecdir flat_libexecdirrel + , mkGetDir flat_sysconfdir flat_sysconfdirrel + ) + | otherwise = + error "panic! generatePathsModule: should never happen" + + mkGetDir :: FilePath -> Maybe FilePath -> String + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir + flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir + flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir + flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir + flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir + flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +-- +-- Note: The format of these strings is part of Cabal's public API; +-- changing this function constitutes a *backwards-compatibility* break. +pkgPathEnvVar + :: PackageDescription + -> String + -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String + -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + +showPkgName :: PackageName -> String +showPkgName = map fixchar . unPackageName + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c diff --git a/src/Distribution/Simple/Build/PathsModule/Z.hs b/src/Distribution/Simple/Build/PathsModule/Z.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/PathsModule/Z.hs @@ -0,0 +1,406 @@ +{- FOURMOLU_DISABLE -} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where +import Distribution.ZinzaPrelude +data Z + = Z {zPackageName :: PackageName, + zVersionDigits :: String, + zSupportsCpp :: Bool, + zSupportsNoRebindableSyntax :: Bool, + zAbsolute :: Bool, + zRelocatable :: Bool, + zIsWindows :: Bool, + zIsI386 :: Bool, + zIsX8664 :: Bool, + zIsAArch64 :: Bool, + zPrefix :: FilePath, + zBindir :: FilePath, + zLibdir :: FilePath, + zDynlibdir :: FilePath, + zDatadir :: FilePath, + zLibexecdir :: FilePath, + zSysconfdir :: FilePath, + zNot :: (Bool -> Bool), + zManglePkgName :: (PackageName -> String)} + deriving Generic +render :: Z -> String +render z_root = execWriter $ do + if (zSupportsCpp z_root) + then do + tell "{-# LANGUAGE CPP #-}\n" + return () + else do + return () + if (zSupportsNoRebindableSyntax z_root) + then do + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" + return () + else do + return () + if (zNot z_root (zAbsolute z_root)) + then do + tell "{-# LANGUAGE ForeignFunctionInterface #-}\n" + return () + else do + return () + if (zSupportsCpp z_root) + then do + tell "#if __GLASGOW_HASKELL__ >= 810\n" + tell "{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}\n" + tell "#endif\n" + return () + else do + return () + tell "{-# OPTIONS_GHC -Wno-missing-import-lists #-}\n" + tell "{-# OPTIONS_GHC -w #-}\n" + tell "\n" + tell "{-|\n" + tell "Module : Paths_" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "\n" + tell "Description : Data file location, and package version and installation\n" + tell " directories.\n" + tell "\n" + tell "WARNING: This module was generated by Cabal. Any modifications will be\n" + tell "overwritten if the module is regenerated.\n" + tell "\n" + tell "This module exports a function to locate data files, and values that record\n" + tell "the version of the package and some directories which the package has been\n" + tell "configured to be installed into.\n" + tell "\n" + tell "For further information about Cabal's options for its configuration step, and\n" + tell "their default values, see the Cabal User Guide.\n" + tell "-}\n" + tell "\n" + tell "module Paths_" + tell (zManglePkgName z_root (zPackageName z_root)) + tell " (\n" + tell " version,\n" + tell " getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,\n" + tell " getDataFileName, getSysconfDir\n" + tell " ) where\n" + tell "\n" + if (zNot z_root (zAbsolute z_root)) + then do + tell "import Foreign\n" + tell "import Foreign.C\n" + return () + else do + return () + tell "\n" + tell "import qualified Control.Exception as Exception\n" + tell "import Data.Version (Version(..))\n" + tell "import System.Environment (getEnv)\n" + tell "import Prelude\n" + tell "\n" + if (zRelocatable z_root) + then do + tell "import System.Environment (getExecutablePath)\n" + return () + else do + return () + tell "\n" + if (zSupportsCpp z_root) + then do + tell "#if defined(VERSION_base)\n" + tell "\n" + tell "#if MIN_VERSION_base(4,0,0)\n" + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "#else\n" + tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n" + tell "#endif\n" + tell "\n" + tell "#else\n" + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "#endif\n" + tell "catchIO = Exception.catch\n" + return () + else do + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "catchIO = Exception.catch\n" + return () + tell "\n" + tell "-- |The package version.\n" + tell "version :: Version\n" + tell "version = Version " + tell (zVersionDigits z_root) + tell " []\n" + tell "\n" + tell "-- |If the argument is a filename, the result is the name of a corresponding\n" + tell "-- file on the system on which the program is running, if the file were listed\n" + tell "-- in the @data-files@ field of the package's Cabal package description file.\n" + tell "-- No check is performed that the given filename is listed in that field.\n" + tell "getDataFileName :: FilePath -> IO FilePath\n" + tell "getDataFileName name = do\n" + tell " dir <- getDataDir\n" + tell " return (dir `joinFileName` name)\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--bindir@ option (where\n" + tell "-- executables that the user might invoke are installed). This can be overridden\n" + tell "-- at runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir.\n" + tell "getBinDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libdir@ option (where\n" + tell "-- object libraries are installed). This can be overridden at runtime using the\n" + tell "-- environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir.\n" + tell "getLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--dynlibdir@ option\n" + tell "-- (where dynamic libraries are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir.\n" + tell "getDynLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--datadir@ option (where\n" + tell "-- architecture-independent data files are installed). This can be overridden at\n" + tell "-- runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir.\n" + tell "getDataDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libexedir@ option\n" + tell "-- (where executables that are not expected to be invoked directly by the user\n" + tell "-- are installed). This can be overridden at runtime using the environment\n" + tell "-- variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexedir.\n" + tell "getLibexecDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--sysconfdir@ option\n" + tell "-- (where configuration files are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir.\n" + tell "getSysconfDir :: IO FilePath\n" + tell "\n" + let + z_var0_function_defs = do + tell "minusFileName :: FilePath -> String -> FilePath\n" + tell "minusFileName dir \"\" = dir\n" + tell "minusFileName dir \".\" = dir\n" + tell "minusFileName dir suffix =\n" + tell " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n" + tell "\n" + tell "splitFileName :: FilePath -> (String, String)\n" + tell "splitFileName p = (reverse (path2++drive), reverse fname)\n" + tell " where\n" + tell " (path,drive) = case p of\n" + tell " (c:':':p') -> (reverse p',[':',c])\n" + tell " _ -> (reverse p ,\"\")\n" + tell " (fname,path1) = break isPathSeparator path\n" + tell " path2 = case path1 of\n" + tell " [] -> \".\"\n" + tell " [_] -> path1 -- don't remove the trailing slash if\n" + tell " -- there is only one character\n" + tell " (c:path') | isPathSeparator c -> path'\n" + tell " _ -> path1\n" + return () + tell "\n" + tell "\n" + if (zRelocatable z_root) + then do + tell "\n" + tell "getPrefixDirReloc :: FilePath -> IO FilePath\n" + tell "getPrefixDirReloc dirRel = do\n" + tell " exePath <- getExecutablePath\n" + tell " let (dir,_) = splitFileName exePath\n" + tell " return ((dir `minusFileName` " + tell (zBindir z_root) + tell ") `joinFileName` dirRel)\n" + tell "\n" + tell "getBinDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir\") (\\_ -> getPrefixDirReloc $ " + tell (zBindir z_root) + tell ")\n" + tell "getLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir\") (\\_ -> getPrefixDirReloc $ " + tell (zLibdir z_root) + tell ")\n" + tell "getDynLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir\") (\\_ -> getPrefixDirReloc $ " + tell (zDynlibdir z_root) + tell ")\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> getPrefixDirReloc $ " + tell (zDatadir z_root) + tell ")\n" + tell "getLibexecDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexecdir\") (\\_ -> getPrefixDirReloc $ " + tell (zLibexecdir z_root) + tell ")\n" + tell "getSysconfDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir\") (\\_ -> getPrefixDirReloc $ " + tell (zSysconfdir z_root) + tell ")\n" + tell "\n" + z_var0_function_defs + tell "\n" + return () + else do + if (zAbsolute z_root) + then do + tell "\n" + tell "bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath\n" + tell "bindir = " + tell (zBindir z_root) + tell "\n" + tell "libdir = " + tell (zLibdir z_root) + tell "\n" + tell "dynlibdir = " + tell (zDynlibdir z_root) + tell "\n" + tell "datadir = " + tell (zDatadir z_root) + tell "\n" + tell "libexecdir = " + tell (zLibexecdir z_root) + tell "\n" + tell "sysconfdir = " + tell (zSysconfdir z_root) + tell "\n" + tell "\n" + tell "getBinDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir\") (\\_ -> return bindir)\n" + tell "getLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir\") (\\_ -> return libdir)\n" + tell "getDynLibDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir\") (\\_ -> return dynlibdir)\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> return datadir)\n" + tell "getLibexecDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexecdir\") (\\_ -> return libexecdir)\n" + tell "getSysconfDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir\") (\\_ -> return sysconfdir)\n" + tell "\n" + return () + else do + if (zIsWindows z_root) + then do + tell "\n" + tell "prefix :: FilePath\n" + tell "prefix = " + tell (zPrefix z_root) + tell "\n" + tell "\n" + tell "getBinDir = getPrefixDirRel $ " + tell (zBindir z_root) + tell "\n" + tell "getLibDir = " + tell (zLibdir z_root) + tell "\n" + tell "getDynLibDir = " + tell (zDynlibdir z_root) + tell "\n" + tell "getDataDir = catchIO (getEnv \"" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir\") (\\_ -> " + tell (zDatadir z_root) + tell ")\n" + tell "getLibexecDir = " + tell (zLibexecdir z_root) + tell "\n" + tell "getSysconfDir = " + tell (zSysconfdir z_root) + tell "\n" + tell "\n" + tell "getPrefixDirRel :: FilePath -> IO FilePath\n" + tell "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n" + tell " where\n" + tell " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n" + tell " ret <- c_GetModuleFileName nullPtr buf size\n" + tell " case ret of\n" + tell " 0 -> return (prefix `joinFileName` dirRel)\n" + tell " _ | ret < size -> do\n" + tell " exePath <- peekCWString buf\n" + tell " let (bindir,_) = splitFileName exePath\n" + tell " return ((bindir `minusFileName` " + tell (zBindir z_root) + tell ") `joinFileName` dirRel)\n" + tell " | otherwise -> try_size (size * 2)\n" + tell "\n" + z_var0_function_defs + tell "\n" + if (zIsI386 z_root) + then do + tell "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + if (zIsX8664 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + if (zIsAArch64 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + tell "-- win32 supported only with I386, X86_64, AArch64\n" + tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + tell "c_GetModuleFileName = _\n" + return () + return () + return () + tell "\n" + return () + else do + tell "\n" + tell "notRelocAbsoluteOrWindows :: ()\n" + tell "notRelocAbsoluteOrWindows = _\n" + tell "\n" + return () + return () + return () + tell "\n" + tell "\n" + tell "joinFileName :: String -> String -> FilePath\n" + tell "joinFileName \"\" fname = fname\n" + tell "joinFileName \".\" fname = fname\n" + tell "joinFileName dir \"\" = dir\n" + tell "joinFileName dir@(c:cs) fname\n" + tell " | isPathSeparator (lastChar c cs) = dir ++ fname\n" + tell " | otherwise = dir ++ pathSeparator : fname\n" + tell " where\n" + tell " -- We do not use Data.List.NonEmpty.last, as that would limit the module to\n" + tell " -- base >= 4.9.0.0 (GHC >= 8.0.1).\n" + tell " lastChar x [] = x\n" + tell " lastChar _ (x:xs) = lastChar x xs\n" + tell "\n" + tell "pathSeparator :: Char\n" + if (zIsWindows z_root) + then do + tell "pathSeparator = '\\\\'\n" + return () + else do + tell "pathSeparator = '/'\n" + return () + tell "\n" + tell "isPathSeparator :: Char -> Bool\n" + if (zIsWindows z_root) + then do + tell "isPathSeparator c = c == '/' || c == '\\\\'\n" + return () + else do + tell "isPathSeparator c = c == '/'\n" + return () diff --git a/src/Distribution/Simple/BuildPaths.hs b/src/Distribution/Simple/BuildPaths.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/BuildPaths.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A bunch of dirs, paths and file names used for intermediate build steps. +module Distribution.Simple.BuildPaths + ( defaultDistPref + , srcPref + , buildInfoPref + , haddockDirName + , haddockLibraryDirPath + , haddockTestDirPath + , haddockBenchmarkDirPath + , hscolourPref + , haddockPref + , autogenPackageModulesDir + , autogenComponentModulesDir + , autogenPathsModuleName + , autogenPackageInfoModuleName + , cppHeaderName + , haddockPath + , haddockPackageLibraryName + , haddockPackageLibraryName' + , haddockLibraryName + , haddockLibraryPath + , mkGenericStaticLibName + , mkLibName + , mkProfLibName + , mkGenericSharedLibName + , mkSharedLibName + , mkProfSharedLibName + , mkStaticLibName + , mkGenericSharedBundledLibName + , exeExtension + , objExtension + , dllExtension + , staticLibExtension + + -- * Source files & build directories + , getSourceFiles + , getLibSourceFiles + , getExeSourceFiles + , getTestSourceFiles + , getBenchmarkSourceFiles + , getFLibSourceFiles + , exeBuildDir + , flibBuildDir + , stubName + , testBuildDir + , benchmarkBuildDir + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.List (stripPrefix) +import Distribution.Compiler +import Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess.Types (builtinHaskellSuffixes) +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Haddock (HaddockTarget (..)) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Utils.Path +import Distribution.Verbosity + +-- --------------------------------------------------------------------------- +-- Build directories and files + +srcPref :: FilePath -> FilePath +srcPref distPref = distPref "src" + +hscolourPref + :: HaddockTarget + -> SymbolicPath root (Dir Dist) + -> PackageDescription + -> SymbolicPath root (Dir Artifacts) +hscolourPref = haddockPref + +-- | Build info json file, generated in every build +buildInfoPref + :: SymbolicPath root (Dir Dist) + -> SymbolicPath root File +buildInfoPref distPref = distPref makeRelativePathEx "build-info.json" + +-- | This is the name of the directory in which the generated haddocks +-- should be stored. It does not include the @/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 + -> SymbolicPath root (Dir Dist) + -> PackageDescription + -> SymbolicPath root (Dir Artifacts) +haddockPref haddockTarget distPref pkg_descr = + distPref makeRelativePathEx ("doc" "html" haddockDirName haddockTarget pkg_descr) + +-- | The directory in which we put auto-generated modules for EVERY +-- component in the package. +autogenPackageModulesDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Source) +autogenPackageModulesDir lbi = buildDir lbi makeRelativePathEx "global-autogen" + +-- | The directory in which we put auto-generated modules for a +-- particular component. +autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source) +autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi makeRelativePathEx "autogen" + +-- NB: Look at 'checkForeignDeps' for where a simplified version of this +-- has been copy-pasted. + +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" + +-- | The name of the auto-generated Paths_* module associated with a package +autogenPathsModuleName :: PackageDescription -> ModuleName +autogenPathsModuleName pkg_descr = + ModuleName.fromString $ + "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr)) + where + fixchar '-' = '_' + fixchar c = c + +-- | The name of the auto-generated PackageInfo_* module associated with a package +autogenPackageInfoModuleName :: PackageDescription -> ModuleName +autogenPackageInfoModuleName pkg_descr = + ModuleName.fromString $ + "PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr)) + where + fixchar '-' = '_' + fixchar c = c + +haddockPath :: PackageDescription -> FilePath +haddockPath pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" + +-- | A name of a (sub)library used by haddock, in the form +-- `:` 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, SymbolicPath Pkg File)] +getLibSourceFiles verbosity lbi lib clbi = + getSourceFiles verbosity mbWorkDir searchpaths modules + where + bi = libBuildInfo lib + modules = allLibModules lib clbi + mbWorkDir = mbWorkDirLBI lbi + searchpaths = + coerceSymbolicPath (componentBuildDir lbi clbi) + : hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + +getExeSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] +getExeSourceFiles verbosity lbi exe clbi = do + moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + mbWorkDir = mbWorkDirLBI lbi + bi = buildInfo exe + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (exeBuildDir lbi exe) + : hsSourceDirs bi + +getTestSourceFiles + :: Verbosity + -> LocalBuildInfo + -> TestSuite + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] +getTestSourceFiles verbosity lbi test@TestSuite{testInterface = TestSuiteExeV10 _ path} clbi = do + moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + mbWorkDir = mbWorkDirLBI lbi + bi = testBuildInfo test + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (testBuildDir lbi test) + : hsSourceDirs bi +getTestSourceFiles _ _ _ _ = return [] + +getBenchmarkSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Benchmark + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] +getBenchmarkSourceFiles verbosity lbi bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ path} clbi = do + moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + mbWorkDir = mbWorkDirLBI lbi + bi = benchmarkBuildInfo bench + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (benchmarkBuildDir lbi bench) + : hsSourceDirs bi +getBenchmarkSourceFiles _ _ _ _ = return [] + +getFLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)] +getFLibSourceFiles verbosity lbi flib clbi = + getSourceFiles verbosity mbWorkDir searchpaths modules + where + bi = foreignLibBuildInfo flib + modules = otherModules bi + mbWorkDir = mbWorkDirLBI lbi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (flibBuildDir lbi flib) + : hsSourceDirs bi + +getSourceFiles + :: Verbosity + -> Maybe (SymbolicPath CWD ('Dir Pkg)) + -> [SymbolicPathX allowAbsolute Pkg (Dir Source)] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, SymbolicPathX allowAbsolute Pkg File)] +getSourceFiles verbosity mbWorkDir dirs modules = flip traverse modules $ \m -> + fmap ((,) m) $ + findFileCwdWithExtension + mbWorkDir + builtinHaskellSuffixes + dirs + (moduleNameSymbolicPath m) + >>= maybe (notFound m) (return . normaliseSymbolicPath) + where + notFound module_ = + dieWithException verbosity $ CantFindSourceModule module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> SymbolicPath Pkg (Dir Build) +exeBuildDir lbi exe = buildDir lbi makeRelativePathEx (nm nm ++ "-tmp") + where + nm = unUnqualComponentName $ exeName exe + +-- | The directory where we put build results for a foreign library +flibBuildDir :: LocalBuildInfo -> ForeignLib -> SymbolicPath Pkg (Dir Build) +flibBuildDir lbi flib = buildDir lbi makeRelativePathEx (nm nm ++ "-tmp") + where + nm = unUnqualComponentName $ foreignLibName flib + +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: TestSuite -> FilePath +stubName t = unUnqualComponentName (testName t) ++ "Stub" + +-- | The directory where we put build results for a test suite +testBuildDir :: LocalBuildInfo -> TestSuite -> SymbolicPath Pkg (Dir Build) +testBuildDir lbi tst = + buildDir lbi makeRelativePathEx testDir + where + testDir = case testInterface tst of + TestSuiteLibV09{} -> + stubName tst stubName tst ++ "-tmp" + _ -> nm nm ++ "-tmp" + nm = unUnqualComponentName $ testName tst + +-- | The directory where we put build results for a benchmark suite +benchmarkBuildDir :: LocalBuildInfo -> Benchmark -> SymbolicPath Pkg (Dir Build) +benchmarkBuildDir lbi bm = + buildDir lbi makeRelativePathEx (nm nm ++ "-tmp") + where + nm = unUnqualComponentName $ benchmarkName bm + +-- --------------------------------------------------------------------------- +-- Library file names + +-- | Create a library name for a static library from a given name. +-- Prepends @lib@ and appends the static library extension (@.a@). +mkGenericStaticLibName :: String -> String +mkGenericStaticLibName lib = "lib" ++ lib <.> "a" + +mkLibName :: UnitId -> String +mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) + +mkProfLibName :: UnitId -> String +mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") + +-- | Create a library name for a shared library from a given name. +-- Prepends @lib@ and appends the @-\\@ +-- as well as the shared library extension. +mkGenericSharedLibName :: Platform -> CompilerId -> String -> String +mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib = + mconcat ["lib", lib, "-", comp <.> dllExtension platform] + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion + +-- Implement proper name mangling for dynamical shared objects +-- @libHS\-\\@ +-- e.g. @libHSbase-2.1-ghc6.6.1.so@ +mkSharedLibName :: Platform -> CompilerId -> UnitId -> String +mkSharedLibName platform comp lib = + mkGenericSharedLibName platform comp (getHSLibraryName lib) + +mkProfSharedLibName :: Platform -> CompilerId -> UnitId -> String +mkProfSharedLibName platform comp lib = + mkGenericSharedLibName platform comp (getHSLibraryName lib ++ "_p") + +-- Static libs are named the same as shared libraries, only with +-- a different extension. +mkStaticLibName :: Platform -> CompilerId -> UnitId -> String +mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib = + "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion + +-- | Create a library name for a bundled shared library from a given name. +-- This matches the naming convention for shared libraries as implemented in +-- GHC's packageHsLibs function in the Packages module. +-- If the given name is prefixed with HS, then this prepends 'lib' and appends +-- the compiler flavour/version and shared library extension e.g.: +-- "HSrts-1.0" -> "libHSrts-1.0-ghc8.7.20190109.so" +-- Otherwise the given name should be prefixed with 'C', then this strips the +-- 'C', prepends 'lib' and appends the shared library extension e.g.: +-- "Cffi" -> "libffi.so" +mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String +mkGenericSharedBundledLibName platform comp lib + | "HS" `isPrefixOf` lib = + mkGenericSharedLibName platform comp lib + | Just lib' <- stripPrefix "C" lib = + "lib" ++ lib' <.> dllExtension platform + | otherwise = + error ("Don't understand library name " ++ lib) + +-- ------------------------------------------------------------ + +-- * Platform file extensions + +-- ------------------------------------------------------------ + +-- | Default extension for executable files on the current platform. +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: Platform -> String +exeExtension platform = case platform of + Platform _ Windows -> "exe" + Platform Wasm32 _ -> "wasm" + _ -> "" + +-- | Extension for object files. For GHC the extension is @\"o\"@. +objExtension :: String +objExtension = "o" + +-- | Extension for dynamically linked (or shared) libraries +-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) +dllExtension :: Platform -> String +dllExtension (Platform _arch os) = case os of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" + +-- | Extension for static libraries +-- +-- TODO: Here, as well as in dllExtension, it's really the target OS that we're +-- interested in, not the build OS. +staticLibExtension :: Platform -> String +staticLibExtension (Platform _arch os) = case os of + Windows -> "lib" + _ -> "a" diff --git a/src/Distribution/Simple/BuildTarget.hs b/src/Distribution/Simple/BuildTarget.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/BuildTarget.hs @@ -0,0 +1,1110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Client.BuildTargets +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified build targets +module Distribution.Simple.BuildTarget + ( -- * Main interface + readTargetInfos + , readBuildTargets -- in case you don't have LocalBuildInfo + + -- * Build targets + , BuildTarget (..) + , showBuildTarget + , QualLevel (..) + , buildTargetComponentName + + -- * Parsing user build targets + , UserBuildTarget + , readUserBuildTargets + , showUserBuildTarget + , UserBuildTargetProblem (..) + , reportUserBuildTargetProblems + + -- * Resolving build targets + , resolveBuildTargets + , BuildTargetProblem (..) + , reportBuildTargetProblems + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.CharParsing as P +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Verbosity + +import Control.Arrow ((&&&)) +import Control.Monad (msum) +import Data.List (groupBy, stripPrefix) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath as FilePath + ( dropExtension + , hasTrailingPathSeparator + , joinPath + , normalise + , splitDirectories + , splitPath + ) + +-- | Take a list of 'String' build targets, and parse and validate them +-- into actual 'TargetInfo's to be built/registered/whatever. +readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] +readTargetInfos verbosity pkg_descr lbi args = do + build_targets <- readBuildTargets verbosity pkg_descr args + checkBuildTargets verbosity pkg_descr lbi build_targets + +-- ------------------------------------------------------------ + +-- * User build targets + +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a build target. +data UserBuildTarget + = -- | A target specified by a single name. This could be a component + -- module or file. + -- + -- > cabal build foo + -- > cabal build Data.Foo + -- > cabal build Data/Foo.hs Data/Foo.hsc + UserBuildTargetSingle String + | -- | A target specified by a qualifier and name. This could be a component + -- name qualified by the component namespace kind, or a module or file + -- qualified by the component name. + -- + -- > cabal build lib:foo exe:foo + -- > cabal build foo:Data.Foo + -- > cabal build foo:Data/Foo.hs + UserBuildTargetDouble String String + | -- | A fully qualified target, either a module or file qualified by a + -- component name with the component namespace kind. + -- + -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs + -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo + UserBuildTargetTriple String String String + deriving (Show, Eq, Ord) + +-- ------------------------------------------------------------ + +-- * Resolved build targets + +-- ------------------------------------------------------------ + +-- | A fully resolved build target. +data BuildTarget + = -- | A specific component + BuildTargetComponent ComponentName + | -- | A specific module within a specific component. + BuildTargetModule ComponentName ModuleName + | -- | A specific file within a specific component. + BuildTargetFile ComponentName FilePath + deriving (Eq, Show, Generic) + +instance Binary BuildTarget + +buildTargetComponentName :: BuildTarget -> ComponentName +buildTargetComponentName (BuildTargetComponent cn) = cn +buildTargetComponentName (BuildTargetModule cn _) = cn +buildTargetComponentName (BuildTargetFile cn _) = cn + +-- | Read a list of user-supplied build target strings and resolve them to +-- 'BuildTarget's according to a 'PackageDescription'. If there are problems +-- with any of the targets e.g. they don't exist or are misformatted, throw an +-- 'IOException'. +readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets verbosity pkg targetStrs = do + let (uproblems, utargets) = readUserBuildTargets targetStrs + reportUserBuildTargetProblems verbosity uproblems + + utargets' <- traverse checkTargetExistsAsFile utargets + + let (bproblems, btargets) = resolveBuildTargets pkg utargets' + reportBuildTargetProblems verbosity bproblems + + return btargets + +checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) +checkTargetExistsAsFile t = do + fexists <- existsAsFile (fileComponentOfTarget t) + return (t, fexists) + where + existsAsFile f = do + exists <- doesFileExist f + case splitPath f of + (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d + (d : _ : _) | not exists -> doesDirectoryExist d + _ -> return exists + + fileComponentOfTarget (UserBuildTargetSingle s1) = s1 + fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 + fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 + +-- ------------------------------------------------------------ + +-- * Parsing user targets + +-- ------------------------------------------------------------ + +readUserBuildTargets + :: [String] + -> ( [UserBuildTargetProblem] + , [UserBuildTarget] + ) +readUserBuildTargets = partitionEithers . map readUserBuildTarget + +-- | +-- +-- >>> readUserBuildTarget "comp" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:comp" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "\"comp\"" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:\"comp\"" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:\"comp\"" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp:more" +-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") +-- +-- >>> readUserBuildTarget "pkg:\"lib\":comp" +-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") +readUserBuildTarget + :: String + -> Either + UserBuildTargetProblem + UserBuildTarget +readUserBuildTarget targetstr = + case explicitEitherParsec parseTargetApprox targetstr of + Left _ -> Left (UserBuildTargetUnrecognised targetstr) + Right tgt -> Right tgt + where + parseTargetApprox :: CabalParsing m => m UserBuildTarget + parseTargetApprox = do + -- read one, two, or three tokens, where last could be "hs-string" + ts <- tokens + return $ case ts of + (a, Nothing) -> UserBuildTargetSingle a + (a, Just (b, Nothing)) -> UserBuildTargetDouble a b + (a, Just (b, Just c)) -> UserBuildTargetTriple a b c + + tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) + tokens = + (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) + + tokens2 :: CabalParsing m => m (String, Maybe String) + tokens2 = + (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) + + token :: CabalParsing m => m String + token = P.munch1 (\x -> not (isSpace x) && x /= ':') + +data UserBuildTargetProblem + = UserBuildTargetUnrecognised String + deriving (Show) + +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do + case [target | UserBuildTargetUnrecognised target <- problems] of + [] -> return () + target -> + dieWithException verbosity $ + UnrecognisedBuildTarget target + +showUserBuildTarget :: UserBuildTarget -> String +showUserBuildTarget = intercalate ":" . getComponents + where + getComponents (UserBuildTargetSingle s1) = [s1] + getComponents (UserBuildTargetDouble s1 s2) = [s1, s2] + getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3] + +-- | Unless you use 'QL1', this function is PARTIAL; +-- use 'showBuildTarget' instead. +showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String +showBuildTarget' ql pkgid bt = + showUserBuildTarget (renderBuildTarget ql bt pkgid) + +-- | Unambiguously render a 'BuildTarget', so that it can +-- be parsed in all situations. +showBuildTarget :: PackageId -> BuildTarget -> String +showBuildTarget pkgid t = + showBuildTarget' (qlBuildTarget t) pkgid t + where + qlBuildTarget BuildTargetComponent{} = QL2 + qlBuildTarget _ = QL3 + +-- ------------------------------------------------------------ + +-- * Resolving user targets to build targets + +-- ------------------------------------------------------------ + +{- +stargets = + [ BuildTargetComponent (CExeName "foo") + , BuildTargetModule (CExeName "foo") (mkMn "Foo") + , BuildTargetModule (CExeName "tst") (mkMn "Foo") + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +resolveBuildTargets + :: PackageDescription + -> [(UserBuildTarget, Bool)] + -> ([BuildTargetProblem], [BuildTarget]) +resolveBuildTargets pkg = + partitionEithers + . map (uncurry (resolveBuildTarget pkg)) + +resolveBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Either BuildTargetProblem BuildTarget +resolveBuildTarget pkg userTarget fexists = + case findMatch (matchBuildTarget pkg userTarget fexists) of + Unambiguous target -> Right target + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') + where + targets' = + disambiguateBuildTargets + (packageId pkg) + userTarget + targets + None errs -> Left (classifyMatchErrors errs) + where + classifyMatchErrors errs + | Just expected' <- NE.nonEmpty expected = + let unzip' = fmap fst &&& fmap snd + (things, got :| _) = unzip' expected' + in BuildTargetExpected userTarget (NE.toList things) got + | not (null nosuch) = BuildTargetNoSuch userTarget nosuch + | otherwise = error $ "resolveBuildTarget: internal error in matching" + where + expected = [(thing, got) | MatchErrorExpected thing got <- errs] + nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs] + +data BuildTargetProblem + = -- | [expected thing] (actually got) + BuildTargetExpected UserBuildTarget [String] String + | -- | [(no such thing, actually got)] + BuildTargetNoSuch UserBuildTarget [(String, String)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] + deriving (Show) + +disambiguateBuildTargets + :: PackageId + -> UserBuildTarget + -> [BuildTarget] + -> [(UserBuildTarget, BuildTarget)] +disambiguateBuildTargets pkgid original = + disambiguate (userTargetQualLevel original) + where + disambiguate ql ts + | null amb = unamb + | otherwise = unamb ++ disambiguate (succ ql) amb + where + (amb, unamb) = step ql ts + + userTargetQualLevel (UserBuildTargetSingle _) = QL1 + userTargetQualLevel (UserBuildTargetDouble _ _) = QL2 + userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 + + step + :: QualLevel + -> [BuildTarget] + -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) + step ql = + (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) + . partition (\g -> length g > 1) + . groupBy (equating fst) + . sortBy (comparing fst) + . map (\t -> (renderBuildTarget ql t pkgid, t)) + +data QualLevel = QL1 | QL2 | QL3 + deriving (Enum, Show) + +renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget +renderBuildTarget ql target pkgid = + case ql of + QL1 -> UserBuildTargetSingle s1 where s1 = single target + QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target + QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target + where + single (BuildTargetComponent cn) = dispCName cn + single (BuildTargetModule _ m) = prettyShow m + single (BuildTargetFile _ f) = f + + double (BuildTargetComponent cn) = (dispKind cn, dispCName cn) + double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) + double (BuildTargetFile cn f) = (dispCName cn, f) + + triple (BuildTargetComponent _) = error "triple BuildTargetComponent" + triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) + triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) + + dispCName = componentStringName pkgid + dispKind = showComponentKindShort . componentKind + +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do + case [(t, e, g) | BuildTargetExpected t e g <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + ReportBuildTargetProblems $ + map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets + + case [(t, e) | BuildTargetNoSuch t e <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + UnknownBuildTarget $ + map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets + + case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + AmbiguousBuildTarget $ + map + ( \(target, amb) -> + ( showUserBuildTarget target + , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb) + ) + ) + targets + where + showBuildTargetKind (BuildTargetComponent _) = "component" + showBuildTargetKind (BuildTargetModule _ _) = "module" + showBuildTargetKind (BuildTargetFile _ _) = "file" + +---------------------------------- +-- Top level BuildTarget matcher +-- + +matchBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Match BuildTarget +matchBuildTarget pkg = \utarget fexists -> + case utarget of + UserBuildTargetSingle str1 -> + matchBuildTarget1 cinfo str1 fexists + UserBuildTargetDouble str1 str2 -> + matchBuildTarget2 cinfo str1 str2 fexists + UserBuildTargetTriple str1 str2 str3 -> + matchBuildTarget3 cinfo str1 str2 str3 fexists + where + cinfo = pkgComponentInfo pkg + +matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchBuildTarget1 cinfo str1 fexists = + matchComponent1 cinfo str1 + `matchPlusShadowing` matchModule1 cinfo str1 + `matchPlusShadowing` matchFile1 cinfo str1 fexists + +matchBuildTarget2 + :: [ComponentInfo] + -> String + -> String + -> Bool + -> Match BuildTarget +matchBuildTarget2 cinfo str1 str2 fexists = + matchComponent2 cinfo str1 str2 + `matchPlusShadowing` matchModule2 cinfo str1 str2 + `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists + +matchBuildTarget3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget +matchBuildTarget3 cinfo str1 str2 str3 fexists = + matchModule3 cinfo str1 str2 str3 + `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists + +data ComponentInfo = ComponentInfo + { cinfoName :: ComponentName + , cinfoStrName :: ComponentStringName + , cinfoSrcDirs :: [FilePath] + , cinfoModules :: [ModuleName] + , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs) + , cinfoAsmFiles :: [FilePath] + , cinfoCmmFiles :: [FilePath] + , cinfoCFiles :: [FilePath] + , cinfoCxxFiles :: [FilePath] + , cinfoJsFiles :: [FilePath] + } + +type ComponentStringName = String + +pkgComponentInfo :: PackageDescription -> [ComponentInfo] +pkgComponentInfo pkg = + [ ComponentInfo + { cinfoName = componentName c + , cinfoStrName = componentStringName pkg (componentName c) + , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi + , cinfoModules = componentModules c + , cinfoHsFiles = map getSymbolicPath $ componentHsFiles c + , cinfoAsmFiles = map getSymbolicPath $ asmSources bi + , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi + , cinfoCFiles = map getSymbolicPath $ cSources bi + , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi + , cinfoJsFiles = map getSymbolicPath $ jsSources bi + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c + ] + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg) +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- TODO: Use of 'explicitLibModules' here is a bit wrong: +-- a user could very well ask to build a specific signature +-- that was inherited from other packages. To fix this +-- we have to plumb 'LocalBuildInfo' through this code. +-- Fortunately, this is only used by 'pkgComponentInfo' +-- Please don't export this function unless you plan on fixing +-- this. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [RelativePath Source File] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles + ( CTest + TestSuite + { testInterface = TestSuiteExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles + ( CBench + Benchmark + { benchmarkInterface = BenchmarkExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles _ = [] + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} + +------------------------------ +-- Matching component kinds +-- + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Show, Enum, Bounded) + +componentKind :: ComponentName -> ComponentKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s `elem` ["lib", "library"] = return' LibKind + | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind + | s `elem` ["exe", "executable"] = return' ExeKind + | s `elem` ["tst", "test", "test-suite"] = return' TestKind + | s `elem` ["bench", "benchmark"] = return' BenchKind + | otherwise = matchErrorExpected "component kind" s + where + return' ck = increaseConfidence >> return ck + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign-library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +------------------------------ +-- Matching component targets +-- + +matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget +matchComponent1 cs = \str1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (BuildTargetComponent (cinfoName c)) + +matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchComponent2 cs = \str1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (BuildTargetComponent (cinfoName c)) + +-- utils: + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = + isAlphaNum c + || c == '.' + || c == '_' + || c == '-' + || c == '\'' + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [(cinfoStrName c, c) | c <- cs] + str + +matchComponentKindAndName + :: [ComponentInfo] + -> ComponentKind + -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str $ + increaseConfidenceFor $ + matchInexactly + (\(ck, cn) -> (ck, caseFold cn)) + [((cinfoKind c, cinfoStrName c), c) | c <- cs] + (ckind, str) + +------------------------------ +-- Matching module targets +-- + +matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget +matchModule1 cs = \str1 -> do + guardModuleName str1 + nubMatchErrors $ do + c <- tryEach cs + let ms = cinfoModules c + m <- matchModuleName ms str1 + return (BuildTargetModule (cinfoName c) m) + +matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchModule2 cs = \str1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (BuildTargetModule (cinfoName c) m) + +matchModule3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Match BuildTarget +matchModule3 cs str1 str2 str3 = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + guardModuleName str3 + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (BuildTargetModule (cinfoName c) m) + +-- utils: + +guardModuleName :: String -> Match () +guardModuleName s + | all validModuleChar s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [ (prettyShow m, m) + | m <- ms + ] + str + +------------------------------ +-- Matching file targets +-- + +matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchFile1 cs str1 exists = + nubMatchErrors $ do + c <- tryEach cs + filepath <- matchComponentFile c str1 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget +matchFile2 cs str1 str2 exists = do + guardComponentName str1 + c <- matchComponentName cs str1 + filepath <- matchComponentFile c str2 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget +matchFile3 cs str1 str2 str3 exists = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + filepath <- matchComponentFile c str3 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath +matchComponentFile c str fexists = + expecting "file" str $ + matchPlus + (matchFileExists str fexists) + ( matchPlusShadowing + ( msum + [ matchModuleFileRooted dirs ms str + , matchOtherFileRooted dirs hsFiles str + ] + ) + ( msum + [ matchModuleFileUnrooted ms str + , matchOtherFileUnrooted hsFiles str + , matchOtherFileUnrooted cFiles str + , matchOtherFileUnrooted jsFiles str + ] + ) + ) + where + dirs = cinfoSrcDirs c + ms = cinfoModules c + hsFiles = cinfoHsFiles c + cFiles = cinfoCFiles c + jsFiles = cinfoJsFiles c + +-- utils + +matchFileExists :: FilePath -> Bool -> Match a +matchFileExists _ False = mzero +matchFileExists fname True = do + increaseConfidence + matchErrorNoSuch "file" fname + +matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath +matchModuleFileUnrooted ms str = do + let filepath = normalise str + _ <- matchModuleFileStem ms filepath + return filepath + +matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath +matchModuleFileRooted dirs ms str = nubMatches $ do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchModuleFileStem ms filepath' + return filepath + +matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName +matchModuleFileStem ms = + increaseConfidenceFor + . matchInexactly + caseFold + [(toFilePath m, m) | m <- ms] + . dropExtension + +matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath +matchOtherFileRooted dirs fs str = do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchFile fs filepath' + return filepath + +matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath +matchOtherFileUnrooted fs str = do + let filepath = normalise str + _ <- matchFile fs filepath + return filepath + +matchFile :: [FilePath] -> FilePath -> Match FilePath +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold [(f, f) | f <- fs] + +matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath +matchDirectoryPrefix dirs filepath = + exactMatches $ + catMaybes + [stripDirectory (normalise dir) filepath | dir <- dirs] + where + stripDirectory :: FilePath -> FilePath -> Maybe FilePath + stripDirectory dir fp = + joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can +-- run a matcher against an input using 'findMatch'. +data Match a + = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving (Show) + +type Confidence = Int + +data MatchError + = MatchErrorExpected String String + | MatchErrorNoSuch String String + deriving (Show, Eq) + +instance Alternative Match where + empty = mzero + (<|>) = mplus + +instance MonadPlus Match where + mzero = matchZero + mplus = matchPlus + +matchZero :: Match a +matchZero = NoMatch 0 [] + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a +matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a +matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a +matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b +matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to 'ambiguousWith' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a +matchPlusShadowing a b = matchPlus a b + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure a = ExactMatch 0 [a] + (<*>) = ap + +instance Monad Match where + return = pure + + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = + addDepth d $ + foldr matchPlus matchZero (map f xs) + InexactMatch d xs >>= f = + addDepth d . forceInexact $ + foldr matchPlus matchZero (map f xs) + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] +matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> Match a -> Match a +orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got +orNoSuchThing _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatches :: Eq a => Match a -> Match a +nubMatches (NoMatch d msgs) = NoMatch d msgs +nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) +nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) + +nubMatchErrors :: Match a -> Match a +nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (ExactMatch d xs) = ExactMatch d xs +nubMatchErrors (InexactMatch d xs) = InexactMatch d xs + +-- | Lift a list of matches to an exact match. +exactMatches, inexactMatches :: [a] -> Match a +exactMatches [] = matchZero +exactMatches xs = ExactMatch 0 xs +inexactMatches [] = matchZero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +findMatch :: Eq b => Match b -> MaybeAmbiguous b +findMatch match = + case match of + NoMatch _ msgs -> None (nub msgs) + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs + where + checkAmbiguous xs = case nub xs of + [x] -> Unambiguous x + xs' -> Ambiguous xs' + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] + deriving (Show) + +------------------------------ +-- Basic matchers +-- + +{- +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) +matchExactly xs = + \x -> case Map.lookup x m of + Nothing -> matchZero + Just ys -> ExactMatch 0 ys + where + m :: Ord a => Map a [b] + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] +-} + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +matchInexactly + :: (Ord a, Ord a') + => (a -> a') + -> [(a, b)] + -> (a -> Match b) +matchInexactly cannonicalise xs = + \x -> case Map.lookup x m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise x) m' of + Just ys -> inexactMatches ys + Nothing -> matchZero + where + m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + +-- | Check that the given build targets are valid in the current context. +-- +-- Also swizzle into a more convenient form. +checkBuildTargets + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [BuildTarget] + -> IO [TargetInfo] +checkBuildTargets _ pkg_descr lbi [] = + return (allTargetsInBuildOrder' pkg_descr lbi) +checkBuildTargets + verbosity + pkg_descr + lbi@(LocalBuildInfo{componentEnabledSpec = enabledComps}) + targets = do + let (enabled, disabled) = + partitionEithers + [ case componentDisabledReason enabledComps comp of + Nothing -> Left target' + Just reason -> Right (cname, reason) + | target <- targets + , let target'@(cname, _) = swizzleTarget target + , let comp = getComponent pkg_descr cname + ] + + case disabled of + [] -> return () + ((cname, reason) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason + + for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) -> + warn verbosity $ + "Ignoring '" + ++ either prettyShow id t + ++ ". The whole " + ++ showComponentName c + ++ " will be processed. (Support for " + ++ "module and file targets has not been implemented yet.)" + + -- Pick out the actual CLBIs for each of these cnames + enabled' <- for enabled $ \(cname, _) -> do + case componentNameTargets' pkg_descr lbi cname of + [] -> error "checkBuildTargets: nothing enabled" + [target] -> return target + _targets -> error "checkBuildTargets: multiple copies enabled" + + return enabled' + where + swizzleTarget (BuildTargetComponent c) = (c, Nothing) + swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) + swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) + + formatReason cn DisabledComponent = + "Cannot process the " + ++ cn + ++ " because the component is marked " + ++ "as disabled in the .cabal file." + formatReason cn DisabledAllTests = + "Cannot process the " + ++ cn + ++ " because test suites are not " + ++ "enabled. Run configure with the flag --enable-tests" + formatReason cn DisabledAllBenchmarks = + "Cannot process the " + ++ cn + ++ " because benchmarks are not " + ++ "enabled. Re-run configure with the flag --enable-benchmarks" + formatReason cn (DisabledAllButOne cn') = + "Cannot process the " + ++ cn + ++ " because this package was " + ++ "configured only to build " + ++ cn' + ++ ". Re-run configure " + ++ "with the argument " + ++ cn diff --git a/src/Distribution/Simple/BuildToolDepends.hs b/src/Distribution/Simple/BuildToolDepends.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/BuildToolDepends.hs @@ -0,0 +1,113 @@ +-- | +-- +-- This modules provides functions for working with both the legacy +-- "build-tools" field, and its replacement, "build-tool-depends". Prefer using +-- the functions contained to access those fields directly. +module Distribution.Simple.BuildToolDepends where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Data.Map as Map + +import Distribution.Package +import Distribution.PackageDescription + +-- | Same as 'desugarBuildTool', but requires atomic information (package +-- name, executable names) instead of a whole 'PackageDescription'. +desugarBuildToolSimple + :: PackageName + -> [UnqualComponentName] + -> LegacyExeDependency + -> Maybe ExeDependency +desugarBuildToolSimple pname exeNames (LegacyExeDependency name reqVer) + | foundLocal = Just $ ExeDependency pname toolName reqVer + | otherwise = Map.lookup name allowMap + where + toolName = mkUnqualComponentName name + foundLocal = toolName `elem` exeNames + allowlist = + [ "hscolour" + , "haddock" + , "happy" + , "alex" + , "hsc2hs" + , "c2hs" + , "cpphs" + , "hspec-discover" + ] + allowMap = Map.fromList $ flip map allowlist $ \n -> + (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + +-- | Desugar a "build-tools" entry into a proper executable dependency if +-- possible. +-- +-- An entry can be so desugared in two cases: +-- +-- 1. The name in build-tools matches a locally defined executable. The +-- executable dependency produced is on that exe in the current package. +-- +-- 2. The name in build-tools matches a hard-coded set of known tools. For now, +-- the executable dependency produced is one an executable in a package of +-- the same, but the hard-coding could just as well be per-key. +-- +-- The first cases matches first. +desugarBuildTool + :: PackageDescription + -> LegacyExeDependency + -> Maybe ExeDependency +desugarBuildTool pkg led = + desugarBuildToolSimple + (packageName pkg) + (map exeName $ executables pkg) + led + +-- | Get everything from "build-tool-depends", along with entries from +-- "build-tools" that we know how to desugar. +-- +-- This should almost always be used instead of just accessing the +-- `buildToolDepends` field directly. +getAllToolDependencies + :: PackageDescription + -> BuildInfo + -> [ExeDependency] +getAllToolDependencies pkg bi = + buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) + +-- | Does the given executable dependency map to this current package? +-- +-- This is a tiny function, but used in a number of places. +-- +-- This function is only sound to call on `BuildInfo`s from the given package +-- description. This is because it just filters the package names of each +-- dependency, and does not check whether version bounds in fact exclude the +-- current package, or the referenced components in fact exist in the current +-- package. +-- +-- This is OK because when a package is loaded, it is checked (in +-- `Distribution.Package.Check`) that dependencies matching internal components +-- do indeed have version bounds accepting the current package, and any +-- depended-on component in the current package actually exists. In fact this +-- check is performed by gathering the internal tool dependencies of each +-- component of the package according to this module, and ensuring those +-- properties on each so-gathered dependency. +-- +-- version bounds and components of the package are unchecked. This is because +-- we sanitize exe deps so that the matching name implies these other +-- conditions. +isInternal :: PackageDescription -> ExeDependency -> Bool +isInternal pkg (ExeDependency n _ _) = n == packageName pkg + +-- | Get internal "build-tool-depends", along with internal "build-tools" +-- +-- This is a tiny function, but used in a number of places. The same +-- restrictions that apply to `isInternal` also apply to this function. +getAllInternalToolDependencies + :: PackageDescription + -> BuildInfo + -> [UnqualComponentName] +getAllInternalToolDependencies pkg bi = + [ toolname + | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi + , isInternal pkg dep + ] 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/CCompiler.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- + +{- +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +-- | +-- Module : Distribution.Simple.CCompiler +-- Copyright : 2011, Dan Knapp +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This simple package provides types and functions for interacting with +-- C compilers. Currently it's just a type enumerating extant C-like +-- languages, which we call dialects. +module Distribution.Simple.CCompiler + ( CDialect (..) + , cSourceExtensions + , cDialectFilenameExtension + , filenameCDialect + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import System.FilePath + ( takeExtension + ) + +-- | Represents a dialect of C. The Monoid instance expresses backward +-- compatibility, in the sense that 'mappend a b' is the least inclusive +-- dialect which both 'a' and 'b' can be correctly interpreted as. +data CDialect + = C + | ObjectiveC + | CPlusPlus + | ObjectiveCPlusPlus + deriving (Eq, Show) + +instance Monoid CDialect where + mempty = C + mappend = (<>) + +instance Semigroup CDialect where + C <> anything = anything + ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus + CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus + _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus + ObjectiveC <> _ = ObjectiveC + CPlusPlus <> _ = CPlusPlus + ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus + +-- | A list of all file extensions which are recognized as possibly containing +-- some dialect of C code. Note that this list is only for source files, +-- not for header files. +cSourceExtensions :: [String] +cSourceExtensions = + [ "c" + , "i" + , "ii" + , "m" + , "mi" + , "mm" + , "M" + , "mii" + , "cc" + , "cp" + , "cxx" + , "cpp" + , "CPP" + , "c++" + , "C" + ] + +-- | Takes a dialect of C and whether code is intended to be passed through +-- the preprocessor, and returns a filename extension for containing that +-- code. +cDialectFilenameExtension :: CDialect -> Bool -> String +cDialectFilenameExtension C True = "c" +cDialectFilenameExtension C False = "i" +cDialectFilenameExtension ObjectiveC True = "m" +cDialectFilenameExtension ObjectiveC False = "mi" +cDialectFilenameExtension CPlusPlus True = "cpp" +cDialectFilenameExtension CPlusPlus False = "ii" +cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" +cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" + +-- | Infers from a filename's extension the dialect of C which it contains, +-- and whether it is intended to be passed through the preprocessor. +filenameCDialect :: String -> Maybe (CDialect, Bool) +filenameCDialect filename = do + extension <- case takeExtension filename of + '.' : ext -> Just ext + _ -> Nothing + case extension of + "c" -> return (C, True) + "i" -> return (C, False) + "ii" -> return (CPlusPlus, False) + "m" -> return (ObjectiveC, True) + "mi" -> return (ObjectiveC, False) + "mm" -> return (ObjectiveCPlusPlus, True) + "M" -> return (ObjectiveCPlusPlus, True) + "mii" -> return (ObjectiveCPlusPlus, False) + "cc" -> return (CPlusPlus, True) + "cp" -> return (CPlusPlus, True) + "cxx" -> return (CPlusPlus, True) + "cpp" -> return (CPlusPlus, True) + "CPP" -> return (CPlusPlus, True) + "c++" -> return (CPlusPlus, True) + "C" -> return (CPlusPlus, True) + _ -> Nothing diff --git a/src/Distribution/Simple/Command.hs b/src/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Command.hs @@ -0,0 +1,801 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : non-portable (ExistentialQuantification) +-- +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- command line completion flags. It is designed to allow other tools make +-- derived commands. This feature is used heavily in @cabal-install@. +module Distribution.Simple.Command + ( -- * Command interface + CommandUI (..) + , commandShowOptions + , CommandParse (..) + , commandParseArgs + , getNormalCommandDescriptions + , helpCommandUI + + -- ** Constructing commands + , ShowOrParseArgs (..) + , usageDefault + , usageAlternatives + , mkCommandUI + , hiddenCommand + + -- ** Associating actions with commands + , Command + , commandAddAction + , noExtraFlags + + -- ** Building lists of commands + , CommandType (..) + , CommandSpec (..) + , commandFromSpec + + -- ** Running commands + , commandsRun + , commandsRunWithFallback + , defaultCommandFallback + + -- * Option Fields + , OptionField (..) + , Name + + -- ** Constructing Option Fields + , option + , multiOption + + -- ** Liftings & Projections + , liftOption + , liftOptionL + + -- * Option Descriptions + , OptDescr (..) + , fmapOptDescr + , Description + , SFlags + , LFlags + , OptFlags + , ArgPlaceHolder + + -- ** OptDescr 'smart' constructors + , MkOptDescr + , reqArg + , reqArg' + , optArg + , optArg' + , optArgDef' + , noArg + , boolOpt + , boolOpt' + , choiceOpt + , choiceOptFromEnum + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import qualified Data.Array as Array +import qualified Data.List as List +import Distribution.Compat.Lens (ALens', (#~), (^#)) +import qualified Distribution.GetOpt as GetOpt +import Distribution.ReadE +import Distribution.Simple.Utils + +data CommandUI flags = CommandUI + { commandName :: String + -- ^ The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + , commandSynopsis :: String + -- ^ A short, one line description of the command to use in help texts. + , commandUsage :: String -> String + -- ^ A function that maps a program name to a usage summary for this + -- command. + , commandDescription :: Maybe (String -> String) + -- ^ Additional explanation of the command to use in help texts. + , commandNotes :: Maybe (String -> String) + -- ^ Post-Usage notes and examples in help texts + , commandDefaultFlags :: flags + -- ^ Initial \/ empty flags + , commandOptions :: ShowOrParseArgs -> [OptionField flags] + -- ^ All the Option fields for this command + } + +data ShowOrParseArgs = ShowArgs | ParseArgs +type Name = String +type Description = String + +-- | We usually have a data type for storing configuration values, where +-- every field stores a configuration option, and the user sets +-- the value either via command line flags or a configuration file. +-- An individual OptionField models such a field, and we usually +-- build a list of options associated to a configuration data type. +data OptionField a = OptionField + { optionName :: Name + , optionDescr :: [OptDescr a] + } + +-- | An OptionField takes one or more OptDescrs, describing the command line +-- interface for the field. +data OptDescr a + = ReqArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (a -> [String]) + | OptArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (String, a -> a) + (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)] + | BoolOpt + Description + OptFlags {-True-} + OptFlags {-False-} + (Bool -> a -> a) + (a -> Maybe Bool) + +fmapOptDescr :: forall a b. (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +fmapOptDescr x u = \case + ReqArg d o p upd get -> ReqArg d o p (fmap m upd) (get . x) + OptArg d o p upd (str, g) get -> OptArg d o p (fmap m upd) (str, m g) (get . x) + ChoiceOpt opts -> ChoiceOpt $ fmap (\(d, o, upd, get) -> (d, o, m upd, get . x)) opts + BoolOpt d true false upd get -> BoolOpt d true false (\b -> m $ upd b) (get . x) + where + m :: (a -> a) -> (b -> b) + m upd_a b = u (upd_a $ x b) b + +-- | Short command line option strings +type SFlags = [Char] + +-- | Long command line option strings +type LFlags = [String] + +type OptFlags = (SFlags, LFlags) +type ArgPlaceHolder = String + +-- | Create an option taking a single OptDescr. +-- No explicit Name is given for the Option, the name is the first LFlag given. +-- +-- Example: @'option' sf lf d get set@ +-- * @sf@: Short option name, for example: @[\'d\']@. No hyphen permitted. +-- * @lf@: Long option name, for example: @["debug"]@. No hyphens permitted. +-- * @d@: Description of the option, shown to the user in help messages. +-- * @get@: Get the current value of the flag. +-- * @set@: Set the value of the flag. Gets the current value of the flag as a +-- parameter. +option + :: SFlags + -> LFlags + -> Description + -> get + -> set + -> MkOptDescr get set a + -> OptionField a +option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = + error $ + "Distribution.command.option: " + ++ "An OptionField must have at least one LFlag" + +-- | Create an option taking several OptDescrs. +-- You will have to give the flags and description individually to the +-- OptDescr constructor. +multiOption + :: Name + -> get + -> set + -> [get -> set -> OptDescr a] + -- ^ MkOptDescr constructors partially + -- applied to flags and description. + -> OptionField a +multiOption n get set args = OptionField n [arg get set | arg <- args] + +type MkOptDescr get set a = + SFlags + -> LFlags + -> Description + -> get + -> set + -> OptDescr a + +-- | Create a string-valued command line interface. +-- Usually called in the context of 'option' or 'multiOption'. +-- +-- Example: @'reqArg' ad mkflag showflag@ +-- +-- * @ad@: Placeholder shown to the user, e.g. @"FILES"@ if files are expected +-- parameters. +-- * @mkflag@: How to parse the argument into the option. +-- * @showflag@: If parsing goes wrong, display a useful error message to +-- the user. +reqArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg ad mkflag showflag sf lf d get set = + ReqArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (showflag . get) + +-- | Create a string-valued command line interface with a default value. +optArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (String, b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag (dv, mkDef) showflag sf lf d get set = + OptArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (dv, \b -> set (get b `mappend` mkDef) b) + (showflag . get) + +-- | (String -> a) variant of "reqArg" +reqArg' + :: Monoid b + => ArgPlaceHolder + -> (String -> b) + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' ad mkflag showflag = + reqArg ad (succeedReadE mkflag) showflag + +-- | (String -> a) variant of "optArg" +optArg' + :: Monoid b + => ArgPlaceHolder + -> (Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' ad mkflag showflag = + optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag + +optArgDef' + :: Monoid b + => ArgPlaceHolder + -> (String, Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArgDef' ad (dv, mkflag) showflag = + optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag + +noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d + +boolOpt + :: (b -> Maybe Bool) + -> (Bool -> b) + -> SFlags + -> SFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n : _) d get set = + BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get) +boolOpt _ _ _ _ _ _ _ _ _ = + error + "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' + :: (b -> Maybe Bool) + -> (Bool -> b) + -> OptFlags + -> OptFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get) + +-- | create a Choice option +choiceOpt + :: Eq b + => [(b, OptFlags, Description)] + -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where + alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff] + +-- | create a Choice option out of an enumeration type. +-- As long flags, the Show output is used. As short flags, the first character +-- which does not conflict with a previous one is used. +choiceOptFromEnum + :: (Bounded b, Enum b, Show b, Eq b) + => MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum _sf _lf d get = + choiceOpt + [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x + ] + _sf + _lf + d + get + where + sflags' = foldl f [] [firstOne ..] + f prev x = + let prevflags = concatMap snd prev + in prev + ++ take + 1 + [ (x, [toLower sf]) + | sf <- show x + , isAlpha sf + , toLower sf `notElem` prevflags + ] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts + :: ShowOrParseArgs + -> CommandUI flags + -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts showOrParse command = + concatMap viewAsGetOpt (commandOptions command showOrParse) + +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] +viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa + where + optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] + optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) = + [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d] + where + set' Nothing = Right def + set' (Just txt) = runReadE set txt + optDescrToGetOpt (ChoiceOpt alts) = + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts] + optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = + [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d] + optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = + [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d] + optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) + ] + +getCurrentChoice :: OptDescr a -> a -> [String] +getCurrentChoice (ChoiceOpt alts) a = + [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a] +getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" + +liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b +liftOption get' set' opt = + opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt} + +-- | @since 3.4.0.0 +liftOptionL :: ALens' b a -> OptionField a -> OptionField b +liftOptionL l = liftOption (^# l) (l #~) + +liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +liftOptDescr get' set' (ChoiceOpt opts) = + ChoiceOpt + [ (d, ff, liftSet get' set' set, (get . get')) + | (d, ff, set, get) <- opts + ] +liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) = + OptArg + d + ff + ad + (liftSet get' set' `fmap` set) + (dv, liftSet get' set' mkDef) + (get . get') +liftOptDescr get' set' (ReqArg d ff ad set get) = + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') +liftOptDescr get' set' (BoolOpt d ffT ffF set get) = + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + +liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b +liftSet get' set' set x = set' (set $ get' x) x + +-- | Show flags in the standard long option command line format +commandShowOptions :: CommandUI flags -> flags -> [String] +commandShowOptions command v = + concat + [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o + ] + where + maybePrefix [] = [] + maybePrefix (lOpt : _) = ["--" ++ lOpt] + + showOptDescr :: a -> OptDescr a -> [String] + showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) = + case enabled x of + Nothing -> [] + Just True -> maybePrefix lfTs + Just False -> maybePrefix lfFs + showOptDescr x c@ChoiceOpt{} = + ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) = + [ "--" ++ lf ++ "=" ++ flag + | flag <- showflag x + ] + showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) = + [ case flag of + Just s -> "--" ++ lf ++ "=" ++ s + Nothing -> "--" ++ lf + | flag <- showflag x + ] + showOptDescr _ _ = + error "Distribution.Simple.Command.showOptDescr: unreachable" + +commandListOptions :: CommandUI flags -> [String] +commandListOptions command = + concatMap listOption $ + addCommonFlags ShowArgs $ -- This is a slight hack, we don't want + -- "--list-options" showing up in the + -- list options output, so use ShowArgs + commandGetOpts ShowArgs command + where + listOption (GetOpt.Option shortNames longNames _ _) = + ["-" ++ [name] | name <- shortNames] + ++ ["--" ++ name | name <- longNames] + +-- | The help text for this command with descriptions of all the options. +commandHelp :: CommandUI flags -> String -> String +commandHelp command pname = + commandSynopsis command + ++ "\n\n" + ++ commandUsage command pname + ++ ( case commandDescription command of + Nothing -> "" + Just desc -> '\n' : desc pname + ) + ++ "\n" + ++ ( if cname == "" + then "Global flags:" + else "Flags for " ++ cname ++ ":" + ) + ++ ( GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command + ) + ++ ( case commandNotes command of + Nothing -> "" + Just notes -> '\n' : notes pname + ) + where + cname = commandName command + +-- | Default "usage" documentation text for commands. +usageDefault :: String -> String -> String +usageDefault name pname = + "Usage: " + ++ pname + ++ " " + ++ name + ++ " [FLAGS]\n\n" + ++ "Flags for " + ++ name + ++ ":" + +-- | Create "usage" documentation from a list of parameter +-- configurations. +usageAlternatives :: String -> [String] -> String -> String +usageAlternatives name strs pname = + unlines + [ start ++ pname ++ " " ++ name ++ " " ++ s + | let starts = "Usage: " : repeat " or: " + , (start, s) <- zip starts strs + ] + +-- | Make a Command from standard 'GetOpt' options. +mkCommandUI + :: String + -- ^ name + -> String + -- ^ synopsis + -> [String] + -- ^ usage alternatives + -> flags + -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) + -- ^ options + -> CommandUI flags +mkCommandUI name synopsis usages flags options = + CommandUI + { commandName = name + , commandSynopsis = synopsis + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives name usages + , commandDefaultFlags = flags + , commandOptions = options + } + +-- | Common flags that apply to every command +data CommonFlag = HelpFlag | ListOptionsFlag + +commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] +commonFlags showOrParseArgs = case showOrParseArgs of + ShowArgs -> [help] + ParseArgs -> [help, list] + where + help = + GetOpt.Option + helpShortFlags + ["help"] + (GetOpt.NoArg HelpFlag) + "Show this help text" + helpShortFlags = case showOrParseArgs of + ShowArgs -> ['h'] + ParseArgs -> ['h', '?'] + list = + GetOpt.Option + [] + ["list-options"] + (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags + :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags showOrParseArgs options = + map (fmap Left) (commonFlags showOrParseArgs) + ++ map (fmap Right) options + +-- | Parse a bunch of command line arguments +commandParseArgs + :: CommandUI flags + -> Bool + -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) +commandParseArgs command global args = + let options = + addCommonFlags ParseArgs $ + commandGetOpts ParseArgs command + order + | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where + listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + where + -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function composition is right to left. + accum flags = foldr (flip (.)) id [f | Right f <- flags] + unrecognised opts = + [ "unrecognized " + ++ "'" + ++ (commandName command) + ++ "'" + ++ " option `" + ++ opt + ++ "'\n" + | opt <- opts + ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x : xs) ys = x : ys ++ xs + +data CommandParse flags + = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags +instance Functor CommandParse where + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs + fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) + +data CommandType = NormalCommand | HiddenCommand +data Command action + = Command String String ([String] -> CommandParse action) CommandType + +-- | Mark command as hidden. Hidden commands don't show up in the 'progname +-- help' or 'progname --help' output. +hiddenCommand :: Command action -> Command action +hiddenCommand (Command name synopsis f _cmdType) = + Command name synopsis f HiddenCommand + +commandAddAction + :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action +commandAddAction command action = + Command + (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + where + applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +-- Print suggested command if edit distance is < 5 +badCommand :: [Command action] -> String -> CommandParse a +badCommand commands' cname = + case eDists of + [] -> CommandErrors [unErr] + (s : _) -> + CommandErrors + [ unErr + , "Maybe you meant `" ++ s ++ "`?\n" + ] + where + eDists = + map fst . List.sortBy (comparing snd) $ + [ (cname', dist) + | -- Note that this is not commandNames, so close suggestions will show + -- hidden commands + (Command cname' _ _ _) <- commands' + , let dist = editDistance cname' cname + , dist < 5 + ] + unErr = "unrecognised command: " ++ cname ++ " (try --help)" + +commandsRun + :: CommandUI a + -> [Command action] + -> [String] + -> IO (CommandParse (a, CommandParse action)) +commandsRun globalCommand commands args = + commandsRunWithFallback globalCommand commands defaultCommandFallback args + +defaultCommandFallback + :: [Command action] + -> String + -> [String] + -> IO (CommandParse action) +defaultCommandFallback commands' name _cmdArgs = pure $ badCommand commands' name + +commandsRunWithFallback + :: CommandUI a + -> [Command action] + -> ([Command action] -> String -> [String] -> IO (CommandParse action)) + -> [String] + -> IO (CommandParse (a, CommandParse action)) +commandsRunWithFallback globalCommand commands defaultCommand args = + case commandParseArgs globalCommand True args of + CommandHelp help -> pure $ CommandHelp help + CommandList opts -> pure $ CommandList (opts ++ commandNames) + CommandErrors errs -> pure $ CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help" : cmdArgs) -> handleHelpCommand flags cmdArgs + (name : cmdArgs) -> case lookupCommand name of + [Command _ _ action _] -> + pure $ CommandReadyToGo (flags, action cmdArgs) + _ -> do + final_cmd <- defaultCommand commands' name cmdArgs + return $ CommandReadyToGo (flags, final_cmd) + [] -> pure $ CommandReadyToGo (flags, noCommand) + where + flags = mkflags (commandDefaultFlags globalCommand) + where + lookupCommand cname = + [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname + ] + + noCommand = CommandErrors ["no command given (try --help)\n"] + + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [name | (Command name _ _ NormalCommand) <- commands'] + + -- A bit of a hack: support "prog help" as a synonym of "prog --help" + -- furthermore, support "prog help command" as "prog command --help" + handleHelpCommand flags cmdArgs = + case commandParseArgs helpCommandUI True cmdArgs of + CommandHelp help -> pure $ CommandHelp help + CommandList list -> pure $ CommandList (list ++ commandNames) + CommandErrors _ -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, (name : cmdArgs')) -> + case lookupCommand name of + [Command _ _ action _] -> + case action ("--help" : cmdArgs') of + CommandHelp help -> pure $ CommandHelp help + CommandList _ -> pure $ CommandList [] + _ -> pure $ CommandHelp globalHelp + _ -> do + fall_back <- defaultCommand commands' name ("--help" : cmdArgs') + return $ CommandReadyToGo (flags, fall_back) + where + globalHelp = commandHelp globalCommand + +-- Levenshtein distance, from https://wiki.haskell.org/Edit_distance +-- (Author: JeanPhilippeBernardy, Simple Permissive Licence) +editDistance :: Eq a => [a] -> [a] -> Int +editDistance xs ys = table Array.! (m, n) + where + (m, n) = (length xs, length ys) + x = Array.array (1, m) (zip [1 ..] xs) + y = Array.array (1, n) (zip [1 ..] ys) + + table :: Array.Array (Int, Int) Int + table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds] + bnds = ((0, 0), (m, n)) + + dist (0, j) = j + dist (i, 0) = i + dist (i, j) = + minimum + [ table Array.! (i - 1, j) + 1 + , table Array.! (i, j - 1) + 1 + , if x Array.! i == y Array.! j + then table Array.! (i - 1, j - 1) + else 1 + table Array.! (i - 1, j - 1) + ] + +-- | Utility function, many commands do not accept additional flags. This +-- action fails with a helpful error message if the user supplies any extra. +noExtraFlags :: [String] -> IO () +noExtraFlags [] = return () +noExtraFlags extraFlags = + dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags + +-- TODO: eliminate this function and turn it into a variant on commandAddAction +-- instead like commandAddActionNoArgs that doesn't supply the [String] + +-- | Helper function for creating globalCommand description +getNormalCommandDescriptions :: [Command action] -> [(String, String)] +getNormalCommandDescriptions cmds = + [ (name, description) + | Command name description _ NormalCommand <- cmds + ] + +helpCommandUI :: CommandUI () +helpCommandUI = + ( mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const []) + ) + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " help help\n" + ++ " Oh, apparently you already know this.\n" + } + +-- | wraps a @CommandUI@ together with a function that turns it into a @Command@. +-- By hiding the type of flags for the UI allows construction of a list of all UIs at the +-- top level of the program. That list can then be used for generation of manual page +-- as well as for executing the selected command. +data CommandSpec action + = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType + +commandFromSpec :: CommandSpec a -> Command a +commandFromSpec (CommandSpec ui action _) = action ui diff --git a/src/Distribution/Simple/Compiler.hs b/src/Distribution/Simple/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Compiler.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like its flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- per-user one and it lets you create arbitrary other package databases. We do +-- not yet fully support this latter feature. +module Distribution.Simple.Compiler + ( -- * Haskell implementations + module Distribution.Compiler + , Compiler (..) + , showCompilerId + , showCompilerIdWithAbi + , compilerFlavor + , compilerVersion + , compilerCompatFlavor + , compilerCompatVersion + , compilerInfo + + -- * Support for package databases + , PackageDB + , PackageDBStack + , PackageDBCWD + , PackageDBStackCWD + , PackageDBX (..) + , PackageDBStackX + , PackageDBS + , PackageDBStackS + , registrationPackageDB + , absolutePackageDBPaths + , absolutePackageDBPath + , interpretPackageDB + , interpretPackageDBStack + , coercePackageDB + , coercePackageDBStack + + -- * Support for optimisation levels + , OptimisationLevel (..) + , flagToOptimisationLevel + + -- * Support for debug info levels + , DebugInfoLevel (..) + , flagToDebugInfoLevel + + -- * Support for language extensions + , CompilerFlag + , languageToFlags + , unsupportedLanguages + , extensionsToFlags + , unsupportedExtensions + , parmakeSupported + , reexportedModulesSupported + , renamingPackageFlagsSupported + , unifiedIPIDRequired + , packageKeySupported + , unitIdSupported + , coverageSupported + , profilingSupported + , profilingDynamicSupported + , profilingDynamicSupportedOrUnknown + , profilingVanillaSupported + , profilingVanillaSupportedOrUnknown + , dynamicSupported + , backpackSupported + , arResponseFilesSupported + , arDashLSupported + , libraryDynDirSupported + , libraryVisibilitySupported + , jsemSupported + , reexportedAsSupported + + -- * Support for profiling detail levels + , ProfDetailLevel (..) + , knownProfDetailLevels + , flagToProfDetailLevel + , showProfDetailLevel + ) where + +import Distribution.Compat.Prelude +import Distribution.Pretty +import Prelude () + +import Distribution.Compiler +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Version + +import Language.Haskell.Extension + +import qualified Data.Map as Map (lookup) +import System.Directory (canonicalizePath) + +data Compiler = Compiler + { compilerId :: CompilerId + -- ^ Compiler flavour and version. + , compilerAbiTag :: AbiTag + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + , compilerCompat :: [CompilerId] + -- ^ Other implementations that this compiler claims to be + -- compatible with. + , compilerLanguages :: [(Language, CompilerFlag)] + -- ^ Supported language standards. + , compilerExtensions :: [(Extension, Maybe CompilerFlag)] + -- ^ Supported extensions. + , compilerProperties :: Map String String + -- ^ A key-value map for properties not covered by the above fields. + } + deriving (Eq, Generic, Show, Read) + +instance Binary Compiler +instance Structured Compiler + +showCompilerId :: Compiler -> String +showCompilerId = prettyShow . compilerId + +showCompilerIdWithAbi :: Compiler -> String +showCompilerIdWithAbi comp = + prettyShow (compilerId comp) + ++ case compilerAbiTag comp of + NoAbiTag -> [] + AbiTag xs -> '-' : xs + +compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor = (\(CompilerId f _) -> f) . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = (\(CompilerId _ v) -> v) . compilerId + +-- | Is this compiler compatible with the compiler flavour we're interested in? +-- +-- For example this checks if the compiler is actually GHC or is another +-- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. +-- +-- > if compilerCompatFlavor GHC compiler then ... else ... +compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool +compilerCompatFlavor flavor comp = + flavor == compilerFlavor comp + || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp] + +-- | Is this compiler compatible with the compiler flavour we're interested in, +-- and if so what version does it claim to be compatible with. +-- +-- For example this checks if the compiler is actually GHC-7.x or is another +-- compiler that claims to be compatible with some GHC-7.x version. +-- +-- > case compilerCompatVersion GHC compiler of +-- > Just (Version (7:_)) -> ... +-- > _ -> ... +compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version +compilerCompatVersion flavor comp + | compilerFlavor comp == flavor = Just (compilerVersion comp) + | otherwise = + listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor] + +compilerInfo :: Compiler -> CompilerInfo +compilerInfo c = + CompilerInfo + (compilerId c) + (compilerAbiTag c) + (Just . compilerCompat $ c) + (Just . map fst . compilerLanguages $ c) + (Just . map fst . compilerExtensions $ c) + +-- ------------------------------------------------------------ + +-- * Package databases + +-- ------------------------------------------------------------ + +-- | Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isolated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +-- +-- Abstracted over +data PackageDBX fp + = GlobalPackageDB + | UserPackageDB + | -- | NB: the path might be relative or it might be absolute + SpecificPackageDB fp + deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable) + +instance Binary fp => Binary (PackageDBX fp) +instance Structured fp => Structured (PackageDBX fp) + +-- | We typically get packages from several databases, and stack them +-- together. This type lets us be explicit about that stacking. For example +-- typical stacks include: +-- +-- > [GlobalPackageDB] +-- > [GlobalPackageDB, UserPackageDB] +-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] +-- +-- Note that the 'GlobalPackageDB' is invariably at the bottom since it +-- contains the rts, base and other special compiler-specific packages. +-- +-- We are not restricted to using just the above combinations. In particular +-- we can use several custom package dbs and the user package db together. +-- +-- When it comes to writing, the top most (last) package is used. +type PackageDBStackX from = [PackageDBX from] + +type PackageDB = PackageDBX (SymbolicPath Pkg (Dir PkgDB)) +type PackageDBStack = PackageDBStackX (SymbolicPath Pkg (Dir PkgDB)) + +type PackageDBS from = PackageDBX (SymbolicPath from (Dir PkgDB)) +type PackageDBStackS from = PackageDBStackX (SymbolicPath from (Dir PkgDB)) + +type PackageDBCWD = PackageDBX FilePath +type PackageDBStackCWD = PackageDBStackX FilePath + +-- | Return the package that we should register into. This is the package db at +-- the top of the stack. +registrationPackageDB :: PackageDBStackX from -> PackageDBX from +registrationPackageDB dbs = case safeLast dbs of + Nothing -> error "internal error: empty package db set" + Just p -> p + +-- | Make package paths absolute +absolutePackageDBPaths + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> IO PackageDBStack +absolutePackageDBPaths mbWorkDir = traverse $ absolutePackageDBPath mbWorkDir + +absolutePackageDBPath + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> IO PackageDB +absolutePackageDBPath _ GlobalPackageDB = return GlobalPackageDB +absolutePackageDBPath _ UserPackageDB = return UserPackageDB +absolutePackageDBPath mbWorkDir (SpecificPackageDB db) = do + let db' = + case symbolicPathRelative_maybe db of + Nothing -> getSymbolicPath db + Just rel_path -> interpretSymbolicPath mbWorkDir rel_path + SpecificPackageDB . makeSymbolicPath <$> canonicalizePath db' + +interpretPackageDB :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageDBCWD +interpretPackageDB _ GlobalPackageDB = GlobalPackageDB +interpretPackageDB _ UserPackageDB = UserPackageDB +interpretPackageDB mbWorkDir (SpecificPackageDB db) = + SpecificPackageDB (interpretSymbolicPath mbWorkDir db) + +interpretPackageDBStack :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageDBStackCWD +interpretPackageDBStack mbWorkDir = map (interpretPackageDB mbWorkDir) + +-- | Transform a package db using a FilePath into one using symbolic paths. +coercePackageDB :: PackageDBCWD -> PackageDBX (SymbolicPath CWD (Dir PkgDB)) +coercePackageDB GlobalPackageDB = GlobalPackageDB +coercePackageDB UserPackageDB = UserPackageDB +coercePackageDB (SpecificPackageDB db) = SpecificPackageDB (makeSymbolicPath db) + +coercePackageDBStack + :: [PackageDBCWD] + -> [PackageDBX (SymbolicPath CWD (Dir PkgDB))] +coercePackageDBStack = map coercePackageDB + +-- ------------------------------------------------------------ + +-- * Optimisation levels + +-- ------------------------------------------------------------ + +-- | Some compilers support optimising. Some have different levels. +-- For compilers that do not the level is just capped to the level +-- they do support. +data OptimisationLevel + = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Bounded, Enum, Eq, Generic, Read, Show) + +instance Binary OptimisationLevel +instance Structured OptimisationLevel + +flagToOptimisationLevel :: Maybe String -> OptimisationLevel +flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) -> + toEnum i + | otherwise -> + error $ + "Bad optimisation level: " + ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s + +-- ------------------------------------------------------------ + +-- * Debug info levels + +-- ------------------------------------------------------------ + +-- | Some compilers support emitting debug info. Some have different +-- levels. For compilers that do not the level is just capped to the +-- level they do support. +data DebugInfoLevel + = NoDebugInfo + | MinimalDebugInfo + | NormalDebugInfo + | MaximalDebugInfo + deriving (Bounded, Enum, Eq, Generic, Read, Show) + +instance Binary DebugInfoLevel +instance Structured DebugInfoLevel + +flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel +flagToDebugInfoLevel Nothing = NormalDebugInfo +flagToDebugInfoLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: DebugInfoLevel) + && i <= fromEnum (maxBound :: DebugInfoLevel) -> + toEnum i + | otherwise -> + error $ + "Bad debug info level: " + ++ show i + ++ ". Valid values are 0..3" + _ -> error $ "Can't parse debug info level " ++ s + +-- ------------------------------------------------------------ + +-- * Languages and Extensions + +-- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs, isNothing (languageToFlag comp lang) + ] + +languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] +languageToFlags comp = + filter (not . null) + . catMaybes + . map (languageToFlag comp) + . maybe [Haskell98] (\x -> [x]) + +languageToFlag :: Compiler -> Language -> Maybe CompilerFlag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + +-- | For the given compiler, return the extensions it does not support. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts, isNothing (extensionToFlag' comp ext) + ] + +type CompilerFlag = String + +-- | For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag] +extensionsToFlags comp = + nub + . filter (not . null) + . catMaybes + . map (extensionToFlag comp) + +-- | Looks up the flag for a given extension, for a given compiler. +-- Ignores the subtlety of extensions which lack associated flags. +extensionToFlag :: Compiler -> Extension -> Maybe CompilerFlag +extensionToFlag comp ext = join (extensionToFlag' comp ext) + +-- | Looks up the flag for a given extension, for a given compiler. +-- However, the extension may be valid for the compiler but not have a flag. +-- For example, NondecreasingIndentation is enabled by default on GHC 7.0.4, +-- hence it is considered a supported extension but not an accepted flag. +-- +-- The outer layer of Maybe indicates whether the extensions is supported, while +-- the inner layer indicates whether it has a flag. +-- When building strings, it is often more convenient to use 'extensionToFlag', +-- which ignores the difference. +extensionToFlag' :: Compiler -> Extension -> Maybe (Maybe CompilerFlag) +extensionToFlag' comp ext = lookup ext (compilerExtensions comp) + +-- | Does this compiler support parallel --make mode? +parmakeSupported :: Compiler -> Bool +parmakeSupported = ghcSupported "Support parallel --make" + +-- | Does this compiler support reexported-modules? +reexportedModulesSupported :: Compiler -> Bool +reexportedModulesSupported = ghcSupported "Support reexported-modules" + +-- | Does this compiler support thinning/renaming on package flags? +renamingPackageFlagsSupported :: Compiler -> Bool +renamingPackageFlagsSupported = + ghcSupported + "Support thinning and renaming package flags" + +-- | Does this compiler have unified IPIDs (so no package keys) +unifiedIPIDRequired :: Compiler -> Bool +unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs" + +-- | Does this compiler support package keys? +packageKeySupported :: Compiler -> Bool +packageKeySupported = ghcSupported "Uses package keys" + +-- | Does this compiler support unit IDs? +unitIdSupported :: Compiler -> Bool +unitIdSupported = ghcSupported "Uses unit IDs" + +-- | Does this compiler support Backpack? +backpackSupported :: Compiler -> Bool +backpackSupported = ghcSupported "Support Backpack" + +-- | Does this compiler support the -jsem option? +jsemSupported :: Compiler -> Bool +jsemSupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [9, 7] + _ -> False + where + v = compilerVersion comp + +-- | Does the compiler support the -reexported-modules "A as B" syntax +reexportedAsSupported :: Compiler -> Bool +reexportedAsSupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [9, 12] + _ -> False + where + v = compilerVersion comp + +-- | Does this compiler support a package database entry with: +-- "dynamic-library-dirs"? +libraryDynDirSupported :: Compiler -> Bool +libraryDynDirSupported comp = case compilerFlavor comp of + GHC -> + -- Not just v >= mkVersion [8,0,1,20161022], as there + -- are many GHC 8.1 nightlies which don't support this. + ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1]) + || v >= mkVersion [8, 1, 20161021] + ) + _ -> False + where + v = compilerVersion comp + +-- | Does this compiler's "ar" command supports response file +-- arguments (i.e. @file-style arguments). +arResponseFilesSupported :: Compiler -> Bool +arResponseFilesSupported = ghcSupported "ar supports at file" + +-- | Does this compiler's "ar" command support llvm-ar's -L flag, +-- which compels the archiver to add an input archive's members +-- rather than adding the archive itself. +arDashLSupported :: Compiler -> Bool +arDashLSupported = ghcSupported "ar supports -L" + +-- | Does this compiler support Haskell program coverage? +coverageSupported :: Compiler -> Bool +coverageSupported comp = + case compilerFlavor comp of + GHC -> True + GHCJS -> True + _ -> False + +-- | Does this compiler support profiling? +profilingSupported :: Compiler -> Bool +profilingSupported comp = + case compilerFlavor comp of + GHC -> True + GHCJS -> True + _ -> False + +-- | Returns Just if we can certainly determine whether a way is supported +-- if we don't know, return Nothing +waySupported :: String -> Compiler -> Maybe Bool +waySupported way comp = + case compilerFlavor comp of + GHC -> + -- Information about compiler ways is only accurately reported after + -- 9.10.1. Which is useful as this is before profiling dynamic support + -- was introduced. (See GHC #24881) + if compilerVersion comp >= mkVersion [9, 10, 1] + then case Map.lookup "RTS ways" (compilerProperties comp) of + Just ways -> Just (way `elem` words ways) + Nothing -> Just False + else Nothing + _ -> Nothing + +-- | Either profiling is definitely supported or we don't know (so assume +-- it is) +profilingVanillaSupportedOrUnknown :: Compiler -> Bool +profilingVanillaSupportedOrUnknown comp = profilingVanillaSupported comp `elem` [Just True, Nothing] + +-- | Is the compiler distributed with profiling libraries +profilingVanillaSupported :: Compiler -> Maybe Bool +profilingVanillaSupported comp = waySupported "p" comp + +-- | Is the compiler distributed with profiling dynamic libraries +profilingDynamicSupported :: Compiler -> Maybe Bool +profilingDynamicSupported comp + | GHC <- compilerFlavor comp + , -- Certainly not before 9.11, as prof+dyn was not implemented yet. + compilerVersion comp <= mkVersion [9, 11, 0] = + Just False + | otherwise = + waySupported "p_dyn" comp + +-- | Either profiling dynamic is definitely supported or we don't know (so assume +-- it is) +profilingDynamicSupportedOrUnknown :: Compiler -> Bool +profilingDynamicSupportedOrUnknown comp = + profilingDynamicSupported comp `elem` [Just True, Nothing] + +-- | Is the compiler distributed with dynamic libraries +dynamicSupported :: Compiler -> Maybe Bool +dynamicSupported comp = waySupported "dyn" comp + +-- | Does this compiler support a package database entry with: +-- "visibility"? +libraryVisibilitySupported :: Compiler -> Bool +libraryVisibilitySupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [8, 8] + _ -> False + where + v = compilerVersion comp + +-- | Utility function for GHC only features +ghcSupported :: String -> Compiler -> Bool +ghcSupported key comp = + case compilerFlavor comp of + GHC -> checkProp + GHCJS -> checkProp + _ -> False + where + checkProp = + case Map.lookup key (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- ------------------------------------------------------------ + +-- * Profiling detail level + +-- ------------------------------------------------------------ + +-- | Some compilers (notably GHC) support profiling and can instrument +-- programs so the system can account costs to different functions. There are +-- different levels of detail that can be used for this accounting. +-- For compilers that do not support this notion or the particular detail +-- levels, this is either ignored or just capped to some similar level +-- they do support. +data ProfDetailLevel + = ProfDetailNone + | ProfDetailDefault + | ProfDetailExportedFunctions + | ProfDetailToplevelFunctions + | ProfDetailAllFunctions + | ProfDetailTopLate + | ProfDetailOther String + deriving (Eq, Generic, Read, Show) + +instance Binary ProfDetailLevel +instance Structured ProfDetailLevel + +flagToProfDetailLevel :: String -> ProfDetailLevel +flagToProfDetailLevel "" = ProfDetailDefault +flagToProfDetailLevel s = + case lookup + (lowercase s) + [ (name, value) + | (primary, aliases, value) <- knownProfDetailLevels + , name <- primary : aliases + ] of + Just value -> value + Nothing -> ProfDetailOther s + +knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] +knownProfDetailLevels = + [ ("default", [], ProfDetailDefault) + , ("none", [], ProfDetailNone) + , ("exported-functions", ["exported"], ProfDetailExportedFunctions) + , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) + , ("all-functions", ["all"], ProfDetailAllFunctions) + , ("late-toplevel", ["late"], ProfDetailTopLate) + ] + +showProfDetailLevel :: ProfDetailLevel -> String +showProfDetailLevel dl = case dl of + ProfDetailNone -> "none" + ProfDetailDefault -> "default" + ProfDetailExportedFunctions -> "exported-functions" + ProfDetailToplevelFunctions -> "toplevel-functions" + ProfDetailAllFunctions -> "all-functions" + ProfDetailTopLate -> "late-toplevel" + ProfDetailOther other -> other diff --git a/src/Distribution/Simple/Configure.hs b/src/Distribution/Simple/Configure.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Configure.hs @@ -0,0 +1,2981 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. +module Distribution.Simple.Configure + ( configure + , configure_setupHooks + , writePersistBuildConfig + , getConfigStateFile + , getPersistBuildConfig + , checkPersistBuildConfigOutdated + , tryGetPersistBuildConfig + , maybeGetPersistBuildConfig + , findDistPref + , findDistPrefOrDefault + , getInternalLibraries + , computeComponentId + , computeCompatPackageKey + , localBuildInfoFile + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getInstalledPackagesById + , getPackageDBContents + , configCompiler + , configCompilerEx + , configCompilerAuxEx + , configCompilerProgDb + , computeEffectiveProfiling + , ccLdOptionsBuildInfo + , checkForeignDeps + , interpretPackageDbFlags + , ConfigStateFileError (..) + , tryGetConfigStateFile + , platformDefines + ) where + +import Control.Monad +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack.Configure +import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) +import Distribution.Backpack.DescribeUnitId +import Distribution.Backpack.Id +import Distribution.Backpack.PreExistingComponent +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Stack +import Distribution.Compiler +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.PrettyPrint +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.BuildWay +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.Db + ( ProgramDb (..) + , lookupProgramByName + , modifyProgramSearchPath + , prependProgramSearchPath + , updateConfiguredProgs + ) +import Distribution.Simple.Setup.Common as Setup +import Distribution.Simple.Setup.Config as Setup +import Distribution.Simple.SetupHooks.Internal + ( ConfigureHooks (..) + , applyComponentDiffs + , noConfigureHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..)) +import Distribution.Types.GivenComponent +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.LocalBuildInfo +import Distribution.Types.MissingDependencyReason (MissingDependencyReason (..)) +import Distribution.Types.PackageVersionConstraint +import Distribution.Utils.LogProgress +import Distribution.Utils.NubList +import Distribution.Utils.String (trim) +import Distribution.Verbosity +import Distribution.Version + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC + +import Control.Exception + ( try + ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.List + ( intersect + , stripPrefix + , (\\) + ) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import Distribution.Compat.Directory + ( doesPathExist + , listDirectory + ) +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Parsec + ( simpleParsec + ) +import Distribution.Pretty + ( defaultStyle + , pretty + , prettyShow + ) +import Distribution.Simple.Errors +import Distribution.Types.AnnotatedId +import Distribution.Utils.Path +import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , removeFile + ) +import System.FilePath + ( isAbsolute + ) +import System.IO + ( hClose + , hPutStrLn + ) +import qualified System.Info + ( compilerName + , compilerVersion + ) +import Text.PrettyPrint + ( Doc + , char + , hsep + , quotes + , renderStyle + , text + , ($+$) + ) + +import qualified Data.Maybe as M +import qualified Data.Set as Set +import qualified Distribution.Compat.NonEmptySet as NES + +type UseExternalInternalDeps = Bool + +-- | The errors that can be thrown when reading the @setup-config@ file. +data ConfigStateFileError + = -- | No header found. + ConfigStateFileNoHeader + | -- | Incorrect header. + ConfigStateFileBadHeader + | -- | Cannot parse file contents. + ConfigStateFileNoParse + | -- | No file! + ConfigStateFileMissing + { cfgStateFileErrorCwd :: Maybe (SymbolicPath CWD (Dir Pkg)) + , cfgStateFileErrorFile :: SymbolicPath Pkg File + } + | -- | Mismatched version. + ConfigStateFileBadVersion + PackageIdentifier + PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) + +-- | Format a 'ConfigStateFileError' as a user-facing error message. +dispConfigStateFileError :: ConfigStateFileError -> Doc +dispConfigStateFileError ConfigStateFileNoHeader = + text "Saved package config file header is missing." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileBadHeader = + text "Saved package config file header is corrupt." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileNoParse = + text "Saved package config file is corrupt." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileMissing{} = + text "Run the 'Setup configure' command first." +dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = + text "Saved package config file is outdated:" + $+$ badCabal + $+$ badCompiler + $+$ text "Re-run the 'Setup configure' command." + where + badCabal = + text "• the Cabal version changed from" + <+> pretty oldCabal + <+> "to" + <+> pretty currentCabalId + badCompiler + | oldCompiler == currentCompilerId = mempty + | otherwise = + text "• the compiler changed from" + <+> pretty oldCompiler + <+> "to" + <+> pretty currentCompilerId + +instance Show ConfigStateFileError where + show = renderStyle defaultStyle . dispConfigStateFileError + +instance Exception ConfigStateFileError + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getConfigStateFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg File + -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo +getConfigStateFile mbWorkDir setupConfigFile = do + let filename = interpretSymbolicPath mbWorkDir setupConfigFile + exists <- doesFileExist filename + unless exists $ throwIO $ ConfigStateFileMissing mbWorkDir setupConfigFile + -- Read the config file into a strict ByteString to avoid problems with + -- lazy I/O, then convert to lazy because the binary package needs that. + contents <- BS.readFile filename + let (header, body) = BLC8.span (/= '\n') (BLC8.fromChunks [contents]) + + (cabalId, compId) <- parseHeader header + + let getStoredValue = do + result <- structuredDecodeOrFailIO (BLC8.tail body) + case result of + Left _ -> throwIO ConfigStateFileNoParse + Right x -> return x + deferErrorIfBadVersion act + | cabalId /= currentCabalId = do + eResult <- try act + throwIO $ ConfigStateFileBadVersion cabalId compId eResult + | otherwise = act + deferErrorIfBadVersion getStoredValue + where + _ = callStack -- TODO: attach call stack to exception + +-- | Read the 'localBuildInfoFile', returning either an error or the local build +-- info. +tryGetConfigStateFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg File + -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile mbWorkDir = try . getConfigStateFile mbWorkDir + +-- | Try to read the 'localBuildInfoFile'. +tryGetPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig mbWorkDir = try . getPersistBuildConfig mbWorkDir + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO LocalBuildInfo +getPersistBuildConfig mbWorkDir distPref = + getConfigStateFile mbWorkDir $ localBuildInfoFile distPref + +-- | Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig mbWorkDir = + liftM (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir + +-- | After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> LocalBuildInfo + -- ^ The 'LocalBuildInfo' to write. + -> IO () +writePersistBuildConfig mbWorkDir distPref lbi = do + createDirectoryIfMissing False (i distPref) + writeFileAtomic (i $ localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, structuredEncode lbi] + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + pkgId = localPackage lbi + +-- | Identifier of the current Cabal package. +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion + +-- | Identifier of the current compiler package. +currentCompilerId :: PackageIdentifier +currentCompilerId = + PackageIdentifier + (mkPackageName System.Info.compilerName) + (mkVersion' System.Info.compilerVersion) + +-- | Parse the @setup-config@ file header, returning the package identifiers +-- for Cabal and the compiler. +parseHeader + :: ByteString + -- ^ The file contents. + -> IO (PackageIdentifier, PackageIdentifier) +parseHeader header = case BLC8.words header of + [ "Saved" + , "package" + , "config" + , "for" + , pkgId + , "written" + , "by" + , cabalId + , "using" + , compId + ] -> + maybe (throwIO ConfigStateFileBadHeader) return $ do + _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier + cabalId' <- simpleParsec (BLC8.unpack cabalId) + compId' <- simpleParsec (BLC8.unpack compId) + return (cabalId', compId') + _ -> throwIO ConfigStateFileNoHeader + +-- | Generate the @setup-config@ file header. +showHeader + :: PackageIdentifier + -- ^ The processed package. + -> ByteString +showHeader pkgId = + BLC8.unwords + [ "Saved" + , "package" + , "config" + , "for" + , toUTF8LBS $ prettyShow pkgId + , "written" + , "by" + , BLC8.pack $ prettyShow currentCabalId + , "using" + , BLC8.pack $ prettyShow currentCompilerId + ] + +-- | Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> SymbolicPath Pkg File + -> IO Bool +checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file = + i pkg_descr_file `moreRecentFile` i (localBuildInfoFile distPref) + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + +-- | Get the path of @dist\/setup-config@. +localBuildInfoFile + :: SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> SymbolicPath Pkg File +localBuildInfoFile distPref = distPref makeRelativePathEx "setup-config" + +-- ----------------------------------------------------------------------------- + +-- * Configuration + +-- ----------------------------------------------------------------------------- + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or the default prefix. +findDistPref + :: SymbolicPath Pkg (Dir Dist) + -- ^ default \"dist\" prefix + -> Setup.Flag (SymbolicPath Pkg (Dir Dist)) + -- ^ override \"dist\" prefix + -> IO (SymbolicPath Pkg (Dir Dist)) +findDistPref defDistPref overrideDistPref = do + envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) + where + parseEnvDistPref env = + case env of + Just distPref | not (null distPref) -> toFlag $ makeSymbolicPath distPref + _ -> NoFlag + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call +-- this function to resolve a @*DistPref@ flag whenever it is not known to be +-- set. (The @*DistPref@ flags are always set to a definite value before +-- invoking 'UserHooks'.) +findDistPrefOrDefault + :: Setup.Flag (SymbolicPath Pkg (Dir Dist)) + -- ^ override \"dist\" prefix + -> IO (SymbolicPath Pkg (Dir Dist)) +findDistPrefOrDefault = findDistPref defaultDistPref + +-- | Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure = configure_setupHooks noConfigureHooks + +configure_setupHooks + :: ConfigureHooks + -> (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure_setupHooks + (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) + (g_pkg_descr, hookedBuildInfo) + cfg = do + -- Cabal pre-configure + let verbosity = fromFlag (configVerbosity cfg) + distPref = fromFlag $ configDistPref cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + + -- Package-wide pre-configure hook + lbc1 <- + case preConfPackageHook of + Nothing -> return lbc0 + Just pre_conf -> do + let programDb0 = LBC.withPrograms lbc0 + programDb0' = programDb0{unconfiguredProgs = Map.empty} + input = + SetupHooks.PreConfPackageInputs + { SetupHooks.configFlags = cfg + , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} + , -- Unconfigured programs are not supplied to the hook, + -- as these cannot be passed over a serialisation boundary + -- (see the "Binary ProgramDb" instance). + SetupHooks.compiler = comp + , SetupHooks.platform = platform + } + SetupHooks.PreConfPackageOutputs + { SetupHooks.buildOptions = opts1 + , SetupHooks.extraConfiguredProgs = progs1 + } <- + pre_conf input + -- The package-wide pre-configure hook returns BuildOptions that + -- overrides the one it was passed in, as well as an update to + -- the ProgramDb in the form of new configured programs to add + -- to the program database. + return $ + lbc0 + { LBC.withBuildOptions = opts1 + , LBC.withPrograms = + updateConfiguredProgs + (`Map.union` progs1) + programDb0 + } + + -- Cabal package-wide configure + (lbc2, pbd2, pkg_info) <- + finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + + -- Package-wide post-configure hook + for_ postConfPackageHook $ \postConfPkg -> do + let input = + SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + } + postConfPkg input + + -- Per-component pre-configure hook + pkg_descr <- do + let pkg_descr2 = LBC.localPkgDescr pbd2 + applyComponentDiffs + verbosity + ( \c -> for preConfComponentHook $ \computeDiff -> do + let input = + SetupHooks.PreConfComponentInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + , SetupHooks.component = c + } + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } <- + computeDiff input + return diff + ) + pkg_descr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} + + -- Cabal per-component configure + externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info + lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps + + writePersistBuildConfig mbWorkDir distPref lbi + + return lbi + +preConfigurePackage + :: ConfigFlags + -> GenericPackageDescription + -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec) +preConfigurePackage cfg g_pkg_descr = do + let verbosity = fromFlag $ configVerbosity cfg + + -- Determine the component we are configuring, if a user specified + -- one on the command line. We use a fake, flattened version of + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription g_pkg_descr + targets0 = configTargets cfg + targets <- readBuildTargets verbosity flat_pkg_descr targets0 + -- TODO: bleat if you use the module/file syntax + let targets' = [cname | BuildTargetComponent cname <- targets] + case targets' of + _ | null targets0 -> return Nothing + [cname] -> return (Just cname) + [] -> dieWithException verbosity NoValidComponent + _ -> dieWithException verbosity ConfigureEitherSingleOrAll + + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId g_pkg_descr) + Just cname -> + setupMessage' + verbosity + "Configuring" + (packageId g_pkg_descr) + cname + (Just (configInstantiateWith cfg)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + dieWithException verbosity ConfigCIDValidForPreComponent + + -- Make a data structure describing what components are enabled. + let enabled :: ComponentRequestedSpec + enabled = case mb_cname of + Just cname -> OneComponentRequestedSpec cname + Nothing -> + ComponentRequestedSpec + { -- The flag name (@--enable-tests@) is a + -- little bit of a misnomer, because + -- just passing this flag won't + -- "enable", in our internal + -- nomenclature; it's just a request; a + -- @buildable: False@ might make it + -- not possible to enable. + testsRequested = fromFlag (configTests cfg) + , benchmarksRequested = + fromFlag (configBenchmarks cfg) + } + -- Some sanity checks related to enabling components. + when + ( isJust mb_cname + && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg)) + ) + $ dieWithException verbosity SanityCheckForEnableComponents + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration verbosity g_pkg_descr cfg + + programDbPre <- mkProgramDb cfg (configPrograms cfg) + -- comp: the compiler we're building with + -- compPlatform: the platform we're building for + -- programDb: location and args of all programs we're + -- building with + ( comp :: Compiler + , compPlatform :: Platform + , programDb00 :: ProgramDb + ) <- + configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + programDbPre + (lessVerbose verbosity) + + -- Where to build the package + let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build + builddir = setupFlagsBuildDir $ configCommonFlags cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + -- NB: create this directory now so that all configure hooks get + -- to see it. (In practice, the Configure build-type needs it before + -- the postConfPackageHook runs.) + createDirectoryIfMissingVerbose (lessVerbose verbosity) True $ + interpretSymbolicPath mbWorkDir builddir + + lbc <- computeLocalBuildConfig cfg comp programDb00 + return (lbc, comp, compPlatform, enabled) + +computeLocalBuildConfig + :: ConfigFlags + -> Compiler + -> ProgramDb + -> IO LBC.LocalBuildConfig +computeLocalBuildConfig cfg comp programDb = do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + -- Decide if we're going to compile with split sections. + split_sections :: Bool <- + if not (fromFlag $ configSplitSections cfg) + then return False + else case compilerFlavor comp of + GHC + | compilerVersion comp >= mkVersion [8, 0] -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-sections; ignoring" + ) + return False + + -- Decide if we're going to compile with split objects. + split_objs :: Bool <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case compilerFlavor comp of + _ | split_sections -> + do + warn + verbosity + ( "--enable-split-sections and " + ++ "--enable-split-objs are mutually " + ++ "exclusive; ignoring the latter" + ) + return False + GHC -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-objs; ignoring" + ) + return False + + -- Basically yes/no/unknown. + let linkerSupportsRelocations :: Maybe Bool + linkerSupportsRelocations = + case lookupProgramByName "ld" programDb of + Nothing -> Nothing + Just ld -> + case Map.lookup "Supports relocatable output" $ programProperties ld of + Just "YES" -> Just True + Just "NO" -> Just False + _other -> Nothing + let ghciLibByDefault = + case compilerId comp of + CompilerId GHC _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- rely on them. By the time that bug was fixed, ghci had + -- been changed to read shared libraries instead of archive + -- files (see next code block). + not (GHC.compilerBuildWay comp `elem` [DynWay, ProfDynWay]) + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + withGHCiLib_ <- + case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of + -- NOTE: If linkerSupportsRelocations is Nothing this may still fail if the + -- linker does not support -r. + True | not (fromMaybe True linkerSupportsRelocations) -> do + warn verbosity $ + "--enable-library-for-ghci is not supported with the current" + ++ " linker; ignoring..." + return False + v -> return v + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of + CompilerId GHC _ -> + -- if ghc is dynamic, then ghci needs a shared + -- library, so we build one by default. + GHC.compilerBuildWay comp == DynWay + CompilerId GHCJS _ -> + GHCJS.isDynamic comp + _ -> False + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg + + withDynExe_ = fromFlag $ configDynExe cfg + + withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg + + setProfiling <- configureProfiling verbosity cfg comp + + setCoverage <- configureCoverage verbosity cfg comp + + -- Turn off library and executable stripping when `debug-info` is set + -- to anything other than zero. + let + strip_libexe s f = + let defaultStrip = fromFlagOrDefault True (f cfg) + in case fromFlag (configDebugInfo cfg) of + NoDebugInfo -> return defaultStrip + _ -> case f cfg of + Flag True -> do + warn verbosity $ + "Setting debug-info implies " + ++ s + ++ "-stripping: False" + return False + _ -> return False + + strip_lib <- strip_libexe "library" configStripLibs + strip_exe <- strip_libexe "executable" configStripExes + + let buildOptions = + setCoverage . setProfiling $ + LBC.BuildOptions + { withVanillaLib = fromFlag $ configVanillaLib cfg + , withSharedLib = withSharedLib_ + , withStaticLib = withStaticLib_ + , withDynExe = withDynExe_ + , withFullyStaticExe = withFullyStaticExe_ + , withProfLib = False + , withProfLibShared = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + , withOptimization = fromFlag $ configOptimization cfg + , withDebugInfo = fromFlag $ configDebugInfo cfg + , withGHCiLib = withGHCiLib_ + , splitSections = split_sections + , splitObjs = split_objs + , stripExes = strip_exe + , stripLibs = strip_lib + , exeCoverage = False + , libCoverage = False + , relocatable = fromFlagOrDefault False $ configRelocatable cfg + } + + -- Dynamic executable, but no shared vanilla libraries + when (LBC.withDynExe buildOptions && not (LBC.withProfExe buildOptions) && not (LBC.withSharedLib buildOptions)) $ + warn verbosity $ + "Executables will use dynamic linking, but a shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + -- Profiled dynamic executable, but no shared profiling libraries + when (LBC.withDynExe buildOptions && LBC.withProfExe buildOptions && not (LBC.withProfLibShared buildOptions)) $ + warn verbosity $ + "Executables will use profiled dynamic linking, but a profiled shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + return $ + LBC.LocalBuildConfig + { extraConfigArgs = [] -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + , withPrograms = programDb + , withBuildOptions = buildOptions + } + +data PackageInfo = PackageInfo + { internalPackageSet :: Set LibraryName + , promisedDepsSet :: Map (PackageName, ComponentName) PromisedComponent + , installedPackageSet :: InstalledPackageIndex + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + } + +configurePackage + :: ConfigFlags + -> LBC.LocalBuildConfig + -> PackageDescription + -> FlagAssignment + -> ComponentRequestedSpec + -> Compiler + -> Platform + -> ProgramDb + -> PackageDBStack + -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) +configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + + -- add extra include/lib dirs as specified in cfg + pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg + -- TODO: it is not clear whether this adding these dirs is necessary + -- when we are directly stating from a PackageDescription (e.g. when + -- cabal-install has determined a PackageDescription, instead of rediscovering + -- when working with a GenericPackageDescription). + -- Could this function call be moved to the end of finalizeAndConfigurePackage + -- right before calling configurePackage? + + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools + -- If --ignore-build-tools is set, no build tool is required: + | fromFlagOrDefault False $ configIgnoreBuildTools cfg = + [] + | otherwise = do + bi <- enabledBuildInfos pkg_descr0 enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) <- + getAllToolDependencies pkg_descr0 bi + , not $ isInternal pkg_descr0 buildTool + ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , Nothing == desugarBuildTool pkg_descr0 buildTool + ] + externBuildToolDeps ++ unknownBuildTools + + programDb1 <- + configureAllKnownPrograms (lessVerbose verbosity) programDb0 + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr2, programDb2) <- + configurePkgconfigPackages verbosity pkg_descr0 programDb1 enabled + + let use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + -- Compute installation directory templates, based on user + -- configuration. + -- + -- TODO: Move this into a helper function. + defaultDirs :: InstallDirTemplates <- + defaultInstallDirs' + use_external_internal_deps + (compilerFlavor comp) + (fromFlag (configUserInstall cfg)) + (hasLibs pkg_descr2) + let + installDirs = + combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs cfg) + lbc = lbc0{LBC.withPrograms = programDb2} + pbd = + LBC.PackageBuildDescr + { configFlags = cfg + , flagAssignment = flags + , componentEnabledSpec = enabled + , compiler = comp + , hostPlatform = platform + , localPkgDescr = pkg_descr2 + , installDirTemplates = installDirs + , withPackageDB = packageDbs + , pkgDescrFile = Nothing + , extraCoverageFor = [] + } + + debug verbosity $ + "Finalized package description:\n" + ++ showPackageDescription pkg_descr2 + + return (lbc, pbd) + +finalizeAndConfigurePackage + :: ConfigFlags + -> LBC.LocalBuildConfig + -> GenericPackageDescription + -> Compiler + -> Platform + -> ComponentRequestedSpec + -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo) +finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + + let programDb0 = LBC.withPrograms lbc0 + -- What package database(s) to use + packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlag (configUserInstall cfg)) + (configPackageDBs cfg) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet :: InstalledPackageIndex <- + getInstalledPackages + (lessVerbose verbosity) + comp + mbWorkDir + packageDbs + programDb0 + + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + let internalPackageSet :: Set LibraryName + internalPackageSet = getInternalLibraries g_pkg_descr + + -- Some sanity checks related to dynamic/static linking. + when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ + dieWithException verbosity SanityCheckForDynamicStaticLinking + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + ( allConstraints :: [PackageVersionConstraint] + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + ) <- + either (dieWithException verbosity) return $ + combinedConstraints + (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + let + promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) + pkg_info = + PackageInfo + { internalPackageSet + , promisedDepsSet + , installedPackageSet + , requiredDepsMap + } + + -- pkg_descr: The resolved package description, that does not contain any + -- conditionals, because we have an assignment for + -- every flag, either picking them ourselves using a + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + let use_external_internal_deps = case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + ( pkg_descr0 :: PackageDescription + , flags :: FlagAssignment + ) <- + configureFinalizedPackage + verbosity + cfg + enabled + allConstraints + ( dependencySatisfiable + use_external_internal_deps + (fromFlagOrDefault False (configExactConfiguration cfg)) + (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) + (packageName g_pkg_descr) + installedPackageSet + internalPackageSet + promisedDepsSet + requiredDepsMap + ) + comp + platform + g_pkg_descr + + (lbc, pbd) <- + configurePackage + cfg + lbc0 + pkg_descr0 + flags + enabled + comp + platform + programDb0 + packageDbs + return (lbc, pbd, pkg_info) + +addExtraIncludeLibDirsFromConfigFlags + :: PackageDescription -> ConfigFlags -> PackageDescription +addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg = + let extraBi = + mempty + { extraLibDirs = configExtraLibDirs cfg + , extraLibDirsStatic = configExtraLibDirsStatic cfg + , extraFrameworkDirs = configExtraFrameworkDirs cfg + , includeDirs = configExtraIncludeDirs cfg + } + modifyLib l = + l + { libBuildInfo = + libBuildInfo l + `mappend` extraBi + } + modifyExecutable e = + e + { buildInfo = + buildInfo e + `mappend` extraBi + } + modifyForeignLib f = + f + { foreignLibBuildInfo = + foreignLibBuildInfo f + `mappend` extraBi + } + modifyTestsuite t = + t + { testBuildInfo = + testBuildInfo t + `mappend` extraBi + } + modifyBenchmark b = + b + { benchmarkBuildInfo = + benchmarkBuildInfo b + `mappend` extraBi + } + in pkg_descr + { library = modifyLib `fmap` library pkg_descr + , subLibraries = modifyLib `map` subLibraries pkg_descr + , executables = modifyExecutable `map` executables pkg_descr + , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr + , testSuites = modifyTestsuite `map` testSuites pkg_descr + , benchmarks = modifyBenchmark `map` benchmarks pkg_descr + } + +finalCheckPackage + :: GenericPackageDescription + -> LBC.PackageBuildDescr + -> HookedBuildInfo + -> PackageInfo + -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) +finalCheckPackage + g_pkg_descr + ( LBC.PackageBuildDescr + { configFlags = cfg + , localPkgDescr = pkg_descr + , compiler = comp + , hostPlatform = compPlatform + , componentEnabledSpec = enabled + } + ) + hookedBuildInfo + (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = + do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + cabalFileDir = packageRoot common + use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + checkCompilerProblems verbosity comp pkg_descr enabled + checkPackageProblems + verbosity + cabalFileDir + g_pkg_descr + (updatePackageDescription hookedBuildInfo pkg_descr) + -- NB: we apply the HookedBuildInfo to check it is valid, + -- but we don't propagate it. + -- Other UserHooks must separately return it again, and we + -- will re-apply it each time. + + -- Check languages and extensions + -- TODO: Move this into a helper function. + let langlist = + nub $ + catMaybes $ + map + defaultLanguage + (enabledBuildInfos pkg_descr enabled) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + dieWithException verbosity $ + UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs) + let extlist = + nub $ + concatMap + allExtensions + (enabledBuildInfos pkg_descr enabled) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + dieWithException verbosity $ + UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (map prettyShow exts) + + -- Check foreign library build requirements + let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] + let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs + when (not (null unsupportedFLibs)) $ + dieWithException verbosity $ + CantFindForeignLibraries unsupportedFLibs + + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + configureDependencies + verbosity + use_external_internal_deps + internalPackageSet + promisedDepsSet + installedPackageSet + requiredDepsMap + pkg_descr + enabled + +configureComponents + :: LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> PackageInfo + -> ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> IO LocalBuildInfo +configureComponents + lbc@(LBC.LocalBuildConfig{withPrograms = programDb}) + pbd0@( LBC.PackageBuildDescr + { configFlags = cfg + , localPkgDescr = pkg_descr + , compiler = comp + , componentEnabledSpec = enabled + } + ) + (PackageInfo{promisedDepsSet, installedPackageSet}) + externalPkgDeps = + do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + -- Compute internal component graph + -- + -- The general idea is that we take a look at all the source level + -- components (which may build-depends on each other) and form a graph. + -- From there, we build a ComponentLocalBuildInfo for each of the + -- components, which lets us actually build each component. + ( buildComponents :: [ComponentLocalBuildInfo] + , packageDependsIndex :: InstalledPackageIndex + ) <- + runLogProgress verbosity $ + configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (fromFlagOrDefault False (configDeterministic cfg)) + (configIPID cfg) + (configCID cfg) + pkg_descr + externalPkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp + + let buildComponentsMap = + foldl' + ( \m clbi -> + Map.insertWith + (++) + (componentLocalName clbi) + [clbi] + m + ) + Map.empty + buildComponents + + let cbd = + LBC.ComponentBuildDescr + { componentGraph = Graph.fromDistinctList buildComponents + , componentNameMap = buildComponentsMap + , promisedPkgs = promisedDepsSet + , installedPkgs = packageDependsIndex + } + + -- For whole-package configure, we determine the + -- extraCoverageFor of the main lib and sub libs here. + extraCoverageUnitIds = case enabled of + -- Whole package configure, add package libs + ComponentRequestedSpec{} -> mapMaybe mbCompUnitId buildComponents + -- Component configure, no need to do anything since + -- extra-coverage-for will be passed for all other components that + -- should be covered. + OneComponentRequestedSpec{} -> [] + mbCompUnitId LibComponentLocalBuildInfo{componentUnitId} = Just componentUnitId + mbCompUnitId _ = Nothing + + pbd = + pbd0 + { LBC.extraCoverageFor = extraCoverageUnitIds + } + + lbd = + LBC.LocalBuildDescr + { packageBuildDescr = pbd + , componentBuildDescr = cbd + } + + lbi = + NewLocalBuildInfo + { localBuildDescr = lbd + , localBuildConfig = lbc + } + + when (LBC.relocatable $ LBC.withBuildOptions lbc) $ + checkRelocatable verbosity pkg_descr lbi + + when (LBC.withDynExe $ LBC.withBuildOptions lbc) $ + checkSharedExes verbosity lbi + + -- TODO: This is not entirely correct, because the dirs may vary + -- across libraries/executables + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to + -- cabal configure, is only a hidden option. It allows packages + -- to be relocatable with their package database. This however + -- breaks when the Paths_* or other includes are used that + -- contain hard coded paths. This is still an open TODO. + -- + -- Allowing ${pkgroot} here, however requires less custom hooks + -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 + unless + ( isAbsolute (prefix dirs) + || "${pkgroot}" `isPrefixOf` prefix dirs + ) + $ dieWithException verbosity + $ ExpectedAbsoluteDirectory (prefix dirs) + + when ("${pkgroot}" `isPrefixOf` prefix dirs) $ + warn verbosity $ + "Using ${pkgroot} in prefix " + ++ prefix dirs + ++ " will not work if you rely on the Path_* module " + ++ " or other hard coded paths. Cabal does not yet " + ++ " support fully relocatable builds! " + ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" + ++ " #4097 #4291 #4872" + + info verbosity $ + "Using " + ++ prettyShow currentCabalId + ++ " compiled by " + ++ prettyShow currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where + relNote = case buildOS of + Windows + | not (hasLibs pkg_descr) + && isNothing isPrefixRelative -> + " (fixed location)" + _ -> "" + + dirinfo "Executables" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) + dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) + + sequence_ + [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programDb + ] + + return lbi + +mkPromisedDepsSet :: [PromisedComponent] -> Map (PackageName, ComponentName) PromisedComponent +mkPromisedDepsSet comps = Map.fromList [((packageName pn, CLibName ln), p) | p@(PromisedComponent pn ln _) <- comps] + +-- | Adds the extra program paths from the flags provided to @configure@ as +-- well as specified locations for certain known programs and their default +-- arguments. +mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb +mkProgramDb cfg initialProgramDb = do + programDb <- + modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths + <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath [] initialProgramDb + pure + . userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ programDb + where + searchpath = fromNubList (configProgramPathExtra cfg) + +-- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path +-- so that we can override the system path. However, in a v2-build, at this point, the "system" path +-- has already been extended by both the built-tools-depends paths, as well as the program-path-extra +-- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_ +-- so as to take effect for v1 builds or standalone calls to Setup.hs +-- In this instance, the lesser evil is to not allow it to override the system path. + +-- ----------------------------------------------------------------------------- +-- Helper functions for configure + +-- | Check if the user used any deprecated flags. +checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () +checkDeprecatedFlags verbosity cfg = do + unless (configProfExe cfg == NoFlag) $ do + let enable + | fromFlag (configProfExe cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-executable-profiling is deprecated. " + ++ "Please use --" + ++ enable + ++ "-profiling instead." + ) + + unless (configLibCoverage cfg == NoFlag) $ do + let enable + | fromFlag (configLibCoverage cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-library-coverage is deprecated. " + ++ "Please use --" + ++ enable + ++ "-coverage instead." + ) + +-- | Sanity check: if '--exact-configuration' was given, ensure that the +-- complete flag assignment was specified on the command line. +checkExactConfiguration + :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration verbosity pkg_descr0 cfg = + when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do + let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) + allFlags = map flagName . genPackageFlags $ pkg_descr0 + diffFlags = allFlags \\ cmdlineFlags + when (not . null $ diffFlags) $ + dieWithException verbosity $ + FlagsNotSpecified diffFlags + +-- | Create a PackageIndex that makes *any libraries that might be* +-- defined internally to this package look like installed packages, in +-- case an executable should refer to any of them as dependencies. +-- +-- It must be *any libraries that might be* defined rather than the +-- actual definitions, because these depend on conditionals in the .cabal +-- file, and we haven't resolved them yet. finalizePD +-- does the resolution of conditionals, and it takes internalPackageSet +-- as part of its input. +getInternalLibraries + :: GenericPackageDescription + -> Set LibraryName +getInternalLibraries pkg_descr0 = + -- TODO: some day, executables will be fair game here too! + let pkg_descr = flattenPackageDescription pkg_descr0 + in Set.fromList (map libName (allLibraries pkg_descr)) + +-- | Returns true if a dependency is satisfiable. This function may +-- report a dependency satisfiable even when it is not, but not vice +-- versa. This is to be passed to finalize +dependencySatisfiable + :: Bool + -- ^ use external internal deps? + -> Bool + -- ^ exact configuration? + -> Bool + -- ^ allow depending on private libs? + -> PackageName + -> InstalledPackageIndex + -- ^ installed set + -> Set LibraryName + -- ^ library components + -> Map (PackageName, ComponentName) PromisedComponent + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required dependencies + -> (Dependency -> DependencySatisfaction) +dependencySatisfiable + use_external_internal_deps + exact_config + allow_private_deps + pn + installedPackageSet + packageLibraries + promisedDeps + requiredDepsMap + (Dependency depName vr sublibs) + | exact_config = + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePD' will fail. + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + if isInternalDep && not use_external_internal_deps + then -- Except for internal deps, when we're NOT per-component mode; + -- those are just True. + internalDepSatisfiable + else -- Backward compatibility for the old sublibrary syntax + + let depComponentName = + CLibName $ LSubLibName $ packageNameToUnqualComponentName depName + invisibleLibraries = NES.filter (not . visible) sublibs + in if sublibs == mainLibSet && Map.member (pn, depComponentName) requiredDepsMap + then Satisfied + else case nonEmpty $ Set.toList invisibleLibraries of + Nothing -> Satisfied + Just invisibleLibraries' -> Unsatisfied $ MissingLibrary invisibleLibraries' + | isInternalDep = + if use_external_internal_deps + then -- When we are doing per-component configure, we now need to + -- test if the internal dependency is in the index. This has + -- DIFFERENT semantics from normal dependency satisfiability. + internalDepSatisfiableExternally + else -- If a 'PackageName' is defined by an internal component, the dep is + -- satisfiable (we're going to build it ourselves) + internalDepSatisfiable + | otherwise = + depSatisfiable + where + -- Internal dependency is when dependency is the same as package. + isInternalDep = pn == depName + + depSatisfiable = + let allVersions = PackageIndex.lookupPackageName installedPackageSet depName + eligibleVersions = + [ version + | (version, _infos) <- PackageIndex.eligibleDependencies allVersions + ] + in if null $ PackageIndex.matchingDependencies vr allVersions + then + if null eligibleVersions + then Unsatisfied $ MissingPackage + else Unsatisfied $ WrongVersion eligibleVersions + else Satisfied + + internalDepSatisfiable = + let missingLibraries = (NES.toSet sublibs) `Set.difference` packageLibraries + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + + internalDepSatisfiableExternally = + -- TODO: Might need to propagate information on which versions _are_ available, if any... + let missingLibraries = + NES.filter (null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + + -- Check whether a library exists and is visible. + -- We don't disambiguate between dependency on non-existent or private + -- library yet, so we just return a bool and later report a generic error. + visible lib = + maybe + False -- Does not even exist (wasn't in the depsMap) + ( \ipi -> + IPI.libVisibility ipi == LibraryVisibilityPublic + -- If the override is enabled, the visibility does + -- not matter (it's handled externally) + || allow_private_deps + -- If it's a library of the same package then it's + -- always visible. + -- This is only triggered when passing a component + -- of the same package as --dependency, such as in: + -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs + || pkgName (IPI.sourcePackageId ipi) == pn + ) + maybeIPI + -- Don't check if it's visible, we promise to build it before we need it. + || promised + where + maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + promised = isJust $ Map.lookup (depName, CLibName lib) promisedDeps + +-- | Finalize a generic package description. +-- +-- The workhorse is 'finalizePD'. +configureFinalizedPackage + :: Verbosity + -> ConfigFlags + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> (Dependency -> DependencySatisfaction) + -- ^ tests if a dependency is satisfiable. + -- Might say it's satisfiable even when not. + -> Compiler + -> Platform + -> GenericPackageDescription + -> IO (PackageDescription, FlagAssignment) +configureFinalizedPackage + verbosity + cfg + enabled + allConstraints + satisfies + comp + compPlatform + pkg_descr0 = do + (pkg_descr, flags) <- + case finalizePD + (configConfigurationsFlags cfg) + enabled + satisfies + compPlatform + (compilerInfo comp) + allConstraints + pkg_descr0 of + Right r -> return r + Left missing -> + dieWithException verbosity $ EncounteredMissingDependency missing + + unless (nullFlagAssignment flags) $ + info verbosity $ + "Flags chosen: " + ++ intercalate + ", " + [ unFlagName fn ++ "=" ++ prettyShow value + | (fn, value) <- unFlagAssignment flags + ] + + return (pkg_descr, flags) + +-- | Check for use of Cabal features which require compiler support +checkCompilerProblems + :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () +checkCompilerProblems verbosity comp pkg_descr enabled = do + unless + ( renamingPackageFlagsSupported comp + || all + (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) + (enabledBuildInfos pkg_descr enabled) + ) + $ dieWithException verbosity CompilerDoesn'tSupportThinning + when + ( any (not . null . reexportedModules) (allLibraries pkg_descr) + && not (reexportedModulesSupported comp) + ) + $ dieWithException verbosity CompilerDoesn'tSupportReexports + when + ( any (not . null . signatures) (allLibraries pkg_descr) + && not (backpackSupported comp) + ) + $ dieWithException verbosity CompilerDoesn'tSupportBackpack + +-- | Select dependencies for the package. +configureDependencies + :: Verbosity + -> UseExternalInternalDeps + -> Set LibraryName + -> Map (PackageName, ComponentName) PromisedComponent + -> InstalledPackageIndex + -- ^ installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required deps + -> PackageDescription + -> ComponentRequestedSpec + -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) +configureDependencies + verbosity + use_external_internal_deps + packageLibraries + promisedDeps + installedPackageSet + requiredDepsMap + pkg_descr + enableSpec = do + let failedDeps :: [FailedDependency] + allPkgDeps :: [ResolvedDependency] + (failedDeps, allPkgDeps) = + partitionEithers $ + concat + [ fmap (\s -> (dep, s)) <$> status + | dep <- enabledBuildDepends pkg_descr enableSpec + , let status = + selectDependency + (package pkg_descr) + packageLibraries + promisedDeps + installedPackageSet + requiredDepsMap + use_external_internal_deps + dep + ] + + internalPkgDeps = + [ pkgid + | (_, InternalDependency pkgid) <- allPkgDeps + ] + -- NB: we have to SAVE the package name, because this is the only + -- way we can be able to resolve package names in the package + -- description. + externalPkgDeps = + [ pec + | (_, ExternalDependency pec) <- allPkgDeps + ] + + promisedPkgDeps = + [ fpec + | (_, PromisedDependency fpec) <- allPkgDeps + ] + + when + ( not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr) + ) + $ dieWithException verbosity + $ LibraryWithinSamePackage internalPkgDeps + reportFailedDependencies verbosity failedDeps + reportSelectedDependencies verbosity allPkgDeps + + return (externalPkgDeps, promisedPkgDeps) + +-- | Select and apply coverage settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureCoverage + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LBC.BuildOptions -> LBC.BuildOptions) +configureCoverage verbosity cfg comp = do + let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) + tryLibCoverage = + fromFlagOrDefault + tryExeCoverage + (mappend (configCoverage cfg) (configLibCoverage cfg)) + -- TODO: Should we also enforce something here on that --coverage-for cannot + -- include indefinite components or instantiations? + if coverageSupported comp + then do + let apply buildOptions = + buildOptions + { LBC.libCoverage = tryLibCoverage + , LBC.exeCoverage = tryExeCoverage + } + return apply + else do + let apply buildOptions = + buildOptions + { LBC.libCoverage = False + , LBC.exeCoverage = False + } + when (tryExeCoverage || tryLibCoverage) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "program coverage. Program coverage has been disabled." + ) + return apply + +-- | Compute the effective value of the profiling flags +-- @--enable-library-profiling@ and @--enable-executable-profiling@ +-- from the specified 'ConfigFlags'. This may be useful for +-- external Cabal tools which need to interact with Setup in +-- a backwards-compatible way: the most predictable mechanism +-- for enabling profiling across many legacy versions is to +-- NOT use @--enable-profiling@ and use those two flags instead. +-- +-- Note that @--enable-executable-profiling@ also affects profiling +-- of benchmarks and (non-detailed) test suites. +computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib vanilla-}, Bool {- lib shared -}, Bool {- exe -}) +computeEffectiveProfiling cfg = + -- The --profiling flag sets the default for both libs and exes, + -- but can be overridden by --library-profiling, or the old deprecated + -- --executable-profiling flag. + -- + -- The --profiling-detail and --library-profiling-detail flags behave + -- similarly + let dynamicExe = fromFlagOrDefault False (configDynExe cfg) + tryExeProfiling = + fromFlagOrDefault + False + (mappend (configProf cfg) (configProfExe cfg)) + tryLibProfiling = + fromFlagOrDefault + (tryExeProfiling && not dynamicExe) + (configProfLib cfg) + tryLibProfilingShared = + fromFlagOrDefault + (tryExeProfiling && dynamicExe) + (configProfShared cfg) + in (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) + +-- | Select and apply profiling settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureProfiling + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LBC.BuildOptions -> LBC.BuildOptions) +configureProfiling verbosity cfg comp = do + let (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling cfg + + tryExeProfileLevel = + fromFlagOrDefault + ProfDetailDefault + (configProfDetail cfg) + tryLibProfileLevel = + fromFlagOrDefault + ProfDetailDefault + ( mappend + (configProfDetail cfg) + (configProfLibDetail cfg) + ) + + checkProfileLevel (ProfDetailOther other) = do + warn + verbosity + ( "Unknown profiling detail level '" + ++ other + ++ "', using default.\nThe profiling detail levels are: " + ++ intercalate + ", " + [name | (name, _, _) <- knownProfDetailLevels] + ) + return ProfDetailDefault + checkProfileLevel other = return other + + applyProfiling <- + if profilingSupported comp && (profilingVanillaSupportedOrUnknown comp || profilingDynamicSupportedOrUnknown comp) + then do + exeLevel <- checkProfileLevel tryExeProfileLevel + libLevel <- checkProfileLevel tryLibProfileLevel + let apply buildOptions = + buildOptions + { LBC.withProfLib = tryLibProfiling + , LBC.withProfLibDetail = libLevel + , LBC.withProfExe = tryExeProfiling + , LBC.withProfExeDetail = exeLevel + } + let compilerSupportsProfilingDynamic = profilingDynamicSupportedOrUnknown comp + apply2 <- + if compilerSupportsProfilingDynamic + then -- Case 1: We support profiled shared libraries so turn on shared profiling + -- libraries if the user asked for it. + return $ \buildOptions -> apply buildOptions{LBC.withProfLibShared = tryLibProfilingShared} + else -- Case 2: Compiler doesn't support profiling shared so turn them off + do + -- If we wanted to enable profiling shared libraries.. tell the + -- user we couldn't. + when (profilingVanillaSupportedOrUnknown comp && tryLibProfilingShared) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling shared objects. Static profiled objects " + ++ "will be built." + ) + return $ \buildOptions -> + let original_options = apply buildOptions + in original_options + { LBC.withProfLibShared = False + , LBC.withProfLib = profilingVanillaSupportedOrUnknown comp && (tryLibProfilingShared || LBC.withProfLib original_options) + , LBC.withDynExe = if LBC.withProfExe original_options then False else LBC.withDynExe original_options + } + + when (tryExeProfiling && not (tryLibProfiling || tryLibProfilingShared)) $ do + warn + verbosity + ( "Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library." + ) + return apply2 + else do + let apply buildOptions = + buildOptions + { LBC.withProfLib = False + , LBC.withProfLibShared = False + , LBC.withProfLibDetail = ProfDetailNone + , LBC.withProfExe = False + , LBC.withProfExeDetail = ProfDetailNone + } + when (tryExeProfiling || tryLibProfiling) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling. Profiling has been disabled." + ) + return apply + + return applyProfiling + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing = + info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) = + info verbosity $ "Using " ++ programName prog ++ version ++ location + where + location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ prettyShow v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +type ResolvedDependency = (Dependency, DependencyResolution) + +data DependencyResolution + = -- | An external dependency from the package database, OR an + -- internal dependency which we are getting from the package + -- database. + ExternalDependency PreExistingComponent + | -- | A promised dependency, which doesn't yet exist, but should be provided + -- at the build time. + -- + -- We have these such that we can configure components without actually + -- building its dependencies, if these dependencies need to be built later + -- again. For example, when launching a multi-repl, + -- we need to build packages in the interactive ghci session, no matter + -- whether they have been built before. + -- Building them in the configure phase is then redundant and costs time. + PromisedDependency ConfiguredPromisedComponent + | -- | An internal dependency ('PackageId' should be a library name) + -- which we are going to have to build. (The + -- 'PackageId' here is a hack to get a modest amount of + -- polymorphism out of the Pkg' typeclass.) + InternalDependency PackageId + +-- | Test for a package dependency and record the version we have installed. +selectDependency + :: PackageId + -- ^ Package id of current package + -> Set LibraryName + -- ^ package libraries + -> Map (PackageName, ComponentName) PromisedComponent + -- ^ Set of components that are promised, i.e. are not installed already. See 'PromisedDependency' for more details. + -> InstalledPackageIndex + -- ^ Installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to + -- use + -> UseExternalInternalDeps + -- ^ Are we configuring a + -- single component? + -> Dependency + -> [Either FailedDependency DependencyResolution] +selectDependency + pkgid + internalIndex + promisedIndex + installedIndex + requiredDepsMap + use_external_internal_deps + (Dependency dep_pkgname vr libs) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + if dep_pkgname == pn + then + if use_external_internal_deps + then do_external_internal <$> NES.toList libs + else do_internal <$> NES.toList libs + else do_external_external <$> NES.toList libs + where + pn = packageName pkgid + + -- It's an internal library, and we're not per-component build + do_internal lib + | Set.member lib internalIndex = + Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + | otherwise = + Left $ DependencyMissingInternal dep_pkgname lib + + -- We have to look it up externally + do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib + | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) + do_external_external lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib + | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) + do_external_internal lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of + -- It's an internal library, being looked up externally + Nothing -> Left (DependencyMissingInternal dep_pkgname lib) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + +reportSelectedDependencies + :: Verbosity + -> [ResolvedDependency] + -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ + unlines + [ "Dependency " + ++ prettyShow (simplifyDependency dep) + ++ ": using " + ++ prettyShow pkgid + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' + PromisedDependency promisedComp -> packageId promisedComp + ] + +reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () +reportFailedDependencies _ [] = return () +reportFailedDependencies verbosity failed = + dieWithException verbosity $ ReportFailedDependencies failed hackageUrl + +-- | List all installed packages in the given package databases. +-- Non-existent package databases do not cause errors, they just get skipped +-- with a warning and treated as empty ones, since technically they do not +-- contain any package. +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -- ^ The stack of package databases. + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do + when (null packageDBs) $ + dieWithException verbosity NoPackageDatabaseSpecified + + info verbosity "Reading installed packages..." + -- do not check empty packagedbs (ghc-pkg would error out) + packageDBs' <- filterM packageDBExists packageDBs + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb + GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb + UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb + flv -> + dieWithException verbosity $ HowToFindInstalledPackages flv + where + packageDBExists (SpecificPackageDB path0) = do + let path = interpretSymbolicPath mbWorkDir path0 + exists <- doesPathExist path + unless exists $ + warn verbosity $ + "Package db " <> path <> " does not exist yet" + return exists + -- Checking the user and global package dbs is more complicated and needs + -- way more data. Also ghc-pkg won't error out unless the user/global + -- pkgdb is overridden with an empty one, so we just don't check for them. + packageDBExists UserPackageDB = pure True + packageDBExists GlobalPackageDB = pure True + +-- | Like 'getInstalledPackages', but for a single package DB. +-- +-- NB: Why isn't this always a fall through to 'getInstalledPackages'? +-- That is because 'getInstalledPackages' performs some sanity checks +-- on the package database stack in question. However, when sandboxes +-- are involved these sanity checks are not desirable. +getPackageDBContents + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getPackageDBContents verbosity mbWorkDir packageDB progdb + GHCJS -> GHCJS.getPackageDBContents verbosity mbWorkDir packageDB progdb + -- For other compilers, try to fall back on 'getInstalledPackages'. + _ -> getInstalledPackages verbosity comp mbWorkDir [packageDB] progdb + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the installed packages. +getInstalledPackagesMonitorFiles + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD ('Dir from)) + -> PackageDBStackS from + -> ProgramDb + -> Platform + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity comp mbWorkDir packageDBs progdb platform = + case compilerFlavor comp of + GHC -> + GHC.getInstalledPackagesMonitorFiles + verbosity + mbWorkDir + platform + progdb + packageDBs + other -> do + warn verbosity $ + "don't know how to find change monitoring files for " + ++ "the installed package databases for " + ++ prettyShow other + return [] + +-- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the +-- 'PackageDBStack' in the 'LocalBuildInfo'. +getInstalledPackagesById + :: (Exception (VerboseException exception), Show exception, Typeable exception) + => Verbosity + -> LocalBuildInfo + -> (UnitId -> exception) + -- ^ Construct an exception that is thrown if a + -- unit-id is not found in the installed packages, + -- from the unit-id that is missing. + -> [UnitId] + -- ^ The unit ids to lookup in the installed packages + -> IO [InstalledPackageInfo] +getInstalledPackagesById verbosity lbi@LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do + let mbWorkDir = mbWorkDirLBI lbi + ipindex <- getInstalledPackages verbosity comp mbWorkDir pkgDb progDb + mapM + ( \uid -> case lookupUnitId ipindex uid of + Nothing -> dieWithException verbosity (mkException uid) + Just ipkg -> return ipkg + ) + unitids + +-- | The user interface specifies the package dbs to use with a combination of +-- @--global@, @--user@ and @--package-db=global|user|clear|$file@. +-- This function combines the global/user flag and interprets the package-db +-- flag into a single package db stack. +interpretPackageDbFlags :: Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp +interpretPackageDbFlags userInstall specificDBs = + extra initialStack specificDBs + where + initialStack + | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] + + extra dbs' [] = dbs' + extra _ (Nothing : dbs) = extra [] dbs + extra dbs' (Just db : dbs) = extra (dbs' ++ [db]) dbs + +-- We are given both --constraint="foo < 2.0" style constraints and also +-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". +-- +-- When finalising the package we have to take into account the specific +-- installed deps we've been given, and the finalise function expects +-- constraints, so we have to translate these deps into version constraints. +-- +-- But after finalising we then have to make sure we pick the right specific +-- deps in the end. So we still need to remember which installed packages to +-- pick. +combinedConstraints + :: [PackageVersionConstraint] + -> [GivenComponent] + -- ^ installed dependencies + -> InstalledPackageIndex + -> Either + CabalException + ( [PackageVersionConstraint] + , Map (PackageName, ComponentName) InstalledPackageInfo + ) +combinedConstraints constraints dependencies installedPackages = do + when (not (null badComponentIds)) $ + Left $ + CombinedConstraints (dispDependencies badComponentIds) + + -- TODO: we don't check that all dependencies are used! + + return (allConstraints, idConstraintMap) + where + allConstraints :: [PackageVersionConstraint] + allConstraints = + constraints + ++ [ thisPackageVersionConstraint (packageId pkg) + | (_, _, _, Just pkg) <- dependenciesPkgInfo + ] + + idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo + idConstraintMap = + Map.fromList + -- NB: do NOT use the packageName from + -- dependenciesPkgInfo! + [ ((pn, cname), pkg) + | (pn, cname, _, Just pkg) <- dependenciesPkgInfo + ] + + -- The dependencies along with the installed package info, if it exists + dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)] + dependenciesPkgInfo = + [ (pkgname, CLibName lname, cid, mpkg) + | GivenComponent pkgname lname cid <- dependencies + , let mpkg = + PackageIndex.lookupComponentId + installedPackages + cid + ] + + -- If we looked up a package specified by an installed package id + -- (i.e. someone has written a hash) and didn't find it then it's + -- an error. + badComponentIds = + [ (pkgname, cname, cid) + | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo + ] + + dispDependencies deps = + hsep + [ text "--dependency=" + <<>> quotes + ( pretty pkgname + <<>> case cname of + CLibName LMainLibName -> "" + CLibName (LSubLibName n) -> ":" <<>> pretty n + _ -> ":" <<>> pretty cname + <<>> char '=' + <<>> pretty cid + ) + | (pkgname, cname, cid) <- deps + ] + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms + :: Verbosity + -> [LegacyExeDependency] + -> ProgramDb + -> IO ProgramDb +configureRequiredPrograms verbosity deps progdb = + foldM (configureRequiredProgram verbosity) progdb deps + +-- | Configure a required program, ensuring that it exists in the PATH +-- (or where the user has specified the program must live) and making it +-- available for use via the 'ProgramDb' interface. If the program is +-- known (exists in the input 'ProgramDb'), we will make sure that the +-- program matches the required version; otherwise we will accept +-- any version of the program and assume that it is a simpleProgram. +configureRequiredProgram + :: Verbosity + -> ProgramDb + -> LegacyExeDependency + -> IO ProgramDb +configureRequiredProgram + verbosity + progdb + (LegacyExeDependency progName verRange) = + case lookupProgramByName progName progdb of + Just prog -> + -- If the program has already been configured, use it + -- (as long as the version is compatible). + -- + -- Not doing so means falling back to the "simpleProgram" path below, + -- which might fail if the program has custom logic to find a version + -- (such as hsc2hs). + let loc = locationPath $ programLocation prog + in case programVersion prog of + Nothing + | verRange == anyVersion -> + return progdb + | otherwise -> + dieWithException verbosity $! + UnknownVersionDb (programId prog) verRange loc + Just version + | withinRange version verRange -> + return progdb + | otherwise -> + dieWithException verbosity $! + BadVersionDb (programId prog) version verRange loc + Nothing -> + -- Otherwise, try to configure it as a 'simpleProgram' automatically + case lookupKnownProgram progName progdb of + Nothing -> + -- There's a bit of a story behind this line. In old versions + -- of Cabal, there were only internal build-tools dependencies. So the + -- behavior in this case was: + -- + -- - If a build-tool dependency was internal, don't do + -- any checking. + -- + -- - If it was external, call 'configureRequiredProgram' to + -- "configure" the executable. In particular, if + -- the program was not "known" (present in 'ProgramDb'), + -- then we would just error. This was fine, because + -- the only way a program could be executed from 'ProgramDb' + -- is if some library code from Cabal actually called it, + -- and the pre-existing Cabal code only calls known + -- programs from 'defaultProgramDb', and so if it + -- is calling something else, you have a Custom setup + -- script, and in that case you are expected to register + -- the program you want to call in the ProgramDb. + -- + -- OK, so that was fine, until I (ezyang, in 2016) refactored + -- Cabal to support per-component builds. In this case, what + -- was previously an internal build-tool dependency now became + -- an external one, and now previously "internal" dependencies + -- are now external. But these are permitted to exist even + -- when they are not previously configured (something that + -- can only occur by a Custom script.) + -- + -- So, I decided, "Fine, let's just accept these in any + -- case." Thus this line. The alternative would have been to + -- somehow detect when a build-tools dependency was "internal" (by + -- looking at the unflattened package description) but this + -- would also be incompatible with future work to support + -- external executable dependencies: we definitely cannot + -- assume they will be preinitialized in the 'ProgramDb'. + configureProgram verbosity (simpleProgram progName) progdb + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, progdb') <- requireProgram verbosity prog progdb + return progdb' + | otherwise -> do + (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb + return progdb' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages + :: Verbosity + -> PackageDescription + -> ProgramDb + -> ComponentRequestedSpec + -> IO (PackageDescription, ProgramDb) +configurePkgconfigPackages verbosity pkg_descr progdb enabled + | null allpkgs = return (pkg_descr, progdb) + | otherwise = do + (_, _, progdb') <- + requireProgramVersion + (lessVerbose verbosity) + pkgConfigProgram + (orLaterVersion $ mkVersion [0, 9, 0]) + progdb + traverse_ requirePkg allpkgs + mlib' <- traverse addPkgConfigBILib (library pkg_descr) + libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) + exes' <- traverse addPkgConfigBIExe (executables pkg_descr) + tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) + benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) + let pkg_descr' = + pkg_descr + { library = mlib' + , subLibraries = libs' + , executables = exes' + , testSuites = tests' + , benchmarks = benches' + } + return (pkg_descr', progdb') + where + allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) + pkgconfig = + getDbProgramOutput + (lessVerbose verbosity) + pkgConfigProgram + progdb + + requirePkg dep@(PkgconfigDependency pkgn range) = do + version <- + pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) + `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) + let v = PkgconfigVersion (toUTF8BS $ trim version) + if not (withinPkgconfigVersionRange v range) + then dieWithException verbosity $ BadVersion pkg versionRequirement v + else info verbosity (depSatisfied v) + where + depSatisfied v = + "Dependency " + ++ prettyShow dep + ++ ": using version " + ++ prettyShow v + + versionRequirement + | isAnyPkgconfigVersion range = "" + | otherwise = " version " ++ prettyShow range + + pkg = unPkgconfigName pkgn + + -- Adds pkgconfig dependencies to the build info for a component + addPkgConfigBI compBI setCompBI comp = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) + return $ setCompBI comp (compBI comp `mappend` bi) + + -- Adds pkgconfig dependencies to the build info for a library + addPkgConfigBILib = addPkgConfigBI libBuildInfo $ + \lib bi -> lib{libBuildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for an executable + addPkgConfigBIExe = addPkgConfigBI buildInfo $ + \exe bi -> exe{buildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for a test suite + addPkgConfigBITest = addPkgConfigBI testBuildInfo $ + \test bi -> test{testBuildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for a benchmark + addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ + \bench bi -> bench{benchmarkBuildInfo = bi} + + pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] +-- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] +-- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) +ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags ldflags_static = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static + (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + in mempty + { includeDirs = map (makeSymbolicPath . drop 2) includeDirs' + , extraLibs = map (drop 2) extraLibs' + , extraLibDirs = map (makeSymbolicPath . drop 2) extraLibDirs' + , extraLibsStatic = map (drop 2) extraLibsStatic' + , extraLibDirsStatic = map (makeSymbolicPath . drop 2) extraLibDirsStatic' + , ccOptions = cflags' + , ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAuxEx + :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +configCompilerAuxEx cfg = do + programDb <- mkProgramDb cfg defaultProgramDb + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + configCompilerEx + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programDb + verbosity + +-- | Configure the compiler and associated programs such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerEx + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCompilerException +configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do + (comp, maybePlatform, programDb) <- case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg progdb + GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure the compiler ONLY. +configCompiler + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompiler mbFlavor hcPath progdb verbosity = do + (comp, maybePlatform, programDb) <- + case mbFlavor of + Nothing -> dieWithException verbosity UnknownCompilerException + Just hcFlavor -> + case hcFlavor of + GHC -> GHC.configureCompiler verbosity hcPath progdb + GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure programs associated to the compiler, such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerProgDb + :: Verbosity + -> Compiler + -> ProgramDb + -- ^ program database containing the compiler + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> IO ProgramDb +configCompilerProgDb verbosity comp hcProgDb hcPkgPath = do + case compilerFlavor comp of + GHC -> GHC.compilerProgramDb verbosity comp hcProgDb hcPkgPath + GHCJS -> GHCJS.compilerProgramDb verbosity comp hcProgDb hcPkgPath + _ -> return hcProgDb + +-- ----------------------------------------------------------------------------- +-- Testing C lib and header dependencies + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = + ifBuildsWith + allHeaders + (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky + (return ()) + ( do + missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs + ) + where + allHeaders = collectField (fmap getSymbolicPath . includes) + allLibs = + collectField $ + if withFullyStaticExe lbi + then extraLibsStatic + else extraLibs + + ifBuildsWith headers args success failure = do + checkDuplicateHeaders + ok <- builds (makeProgram headers) args + if ok then success else failure + + -- Ensure that there is only one header with a given name + -- in either the generated (most likely by `configure`) + -- build directory (e.g. `dist/build`) or in the source directory. + -- + -- If it exists in both, we'll remove the one in the source + -- directory, as the generated should take precedence. + -- + -- C compilers like to prefer source local relative includes, + -- so the search paths provided to the compiler via -I are + -- ignored if the included file can be found relative to the + -- including file. As such we need to take drastic measures + -- and delete the offending file in the source directory. + checkDuplicateHeaders = do + let relIncDirs = filter (not . isAbsolute) (collectField (fmap getSymbolicPath . includeDirs)) + isHeader = isSuffixOf ".h" + genHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (i (buildDir lbi) dir) `catchIO` (\_ -> return []) + srcHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (baseDir dir) `catchIO` (\_ -> return []) + let commonHeaders = concat genHeaders `intersect` concat srcHeaders + for_ commonHeaders $ \hdr -> do + warn verbosity $ + "Duplicate header found in " + ++ (getSymbolicPath (buildDir lbi) hdr) + ++ " and " + ++ (baseDir hdr) + ++ "; removing " + ++ (baseDir hdr) + removeFile (baseDir hdr) + + findOffendingHdr = + ifBuildsWith + allHeaders + ccArgs + (return Nothing) + (go . tail . NEL.inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs : hdrsInits) = + -- Try just preprocessing first + ifBuildsWith + hdrs + cppArgs + -- If that works, try compiling too + ( ifBuildsWith + hdrs + ccArgs + (go hdrsInits) + (return . fmap Right . safeLast $ hdrs) + ) + (return . fmap Left . safeLast $ hdrs) + + cppArgs = "-E" : commonCppArgs -- preprocess only + ccArgs = "-c" : commonCcArgs -- don't try to link + findMissingLibs = + ifBuildsWith + [] + (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + common = configCommonFlags $ configFlags lbi + baseDir = packageRoot common + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + mbWorkDir = mbWorkDirLBI lbi + + commonCppArgs = + platformDefines lbi + -- TODO: This is a massive hack, to work around the + -- fact that the test performed here should be + -- PER-component (c.f. the "I'm Feeling Lucky"; we + -- should NOT be glomming everything together.) + ++ ["-I" ++ i (buildDir lbi makeRelativePathEx "autogen")] + -- `configure' may generate headers in the build directory + ++ [ "-I" ++ i (buildDir lbi unsafeCoerceSymbolicPath dir) + | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) + ] + -- we might also reference headers from the + -- packages directory. + ++ [ "-I" ++ baseDir getSymbolicPath dir + | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) + ] + ++ [ "-I" ++ dir + | dir <- ordNub (collectField (fmap getSymbolicPath . includeDirs)) + , isAbsolute dir + ] + ++ ["-I" ++ baseDir] + ++ collectField cppOptions + ++ collectField ccOptions + ++ [ "-I" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- IPI.includeDirs dep + ] + -- dedupe include dirs of dependencies + -- to prevent quadratic blow-up + ] + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonCcArgs = + commonCppArgs + ++ collectField ccOptions + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonLdArgs = + [ "-L" ++ getSymbolicPath dir + | dir <- + ordNub $ + collectField + ( if withFullyStaticExe lbi + then extraLibDirsStatic + else extraLibDirs + ) + ] + ++ collectField ldOptions + ++ [ "-L" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- + if withFullyStaticExe lbi + then IPI.libraryDirsStatic dep + else IPI.libraryDirs dep + ] + ] + -- TODO: do we also need dependent packages' ld options? + makeLdArgs libs = ["-l" ++ lib | lib <- libs] ++ commonLdArgs + + makeProgram hdrs = + unlines $ + ["#include \"" ++ hdr ++ "\"" | hdr <- hdrs] + ++ ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds :: String -> [ProgArg] -> IO Bool + builds program args = + withTempFileCwd ".c" $ \cName cHnd -> + withTempFileCwd "" $ \oNname oHnd -> + do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- + getDbProgramOutputCwd + verbosity + mbWorkDir + gccProgram + (withPrograms lbi) + (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors _ _ + | isNothing . lookupProgram gccProgram . withPrograms $ lbi = + dieWithException verbosity NoWorkingGcc + explainErrors hdr libs = + dieWithException verbosity $ ExplainErrors hdr libs + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems + :: Verbosity + -> FilePath + -- ^ Path to the @.cabal@ file's directory + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity dir gpkg pkg = do + ioChecks <- checkPackageFiles verbosity pkg dir + let pureChecks = checkPackage gpkg + (errors, warnings) = + partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) + if null errors + then traverse_ (warn verbosity) (map ppPackageCheck warnings) + else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors) + where + -- Classify error/warnings. Left: error, Right: warning. + classEW :: PackageCheck -> Maybe (Either PackageCheck PackageCheck) + classEW e@(PackageBuildImpossible _) = Just (Left e) + classEW w@(PackageBuildWarning _) = Just (Right w) + classEW (PackageDistSuspicious _) = Nothing + classEW (PackageDistSuspiciousWarn _) = Nothing + classEW (PackageDistInexcusable _) = Nothing + +-- | Perform checks if a shared executable can be built +checkSharedExes + :: Verbosity + -> LocalBuildInfo + -> IO () +checkSharedExes verbosity lbi = + when (os == Windows) $ + dieWithException verbosity $ + NoOSSupport os "shared executables" + where + (Platform _ os) = hostPlatform lbi + +-- | Preform checks if a relocatable build is allowed +checkRelocatable + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +checkRelocatable verbosity pkg lbi = + sequence_ + [ checkOS + , checkCompiler + , packagePrefixRelative + , depsPrefixRelative + ] + where + -- Check if the OS support relocatable builds. + -- + -- If you add new OS' to this list, and your OS supports dynamic libraries + -- and RPATH, make sure you add your OS to RPATH-support list of: + -- Distribution.Simple.GHC.getRPaths + checkOS = + unless (os `elem` [OSX, Linux]) $ + dieWithException verbosity $ + NoOSSupport os "relocatable builds" + where + (Platform _ os) = hostPlatform lbi + + -- Check if the Compiler support relocatable builds + checkCompiler = + unless (compilerFlavor comp `elem` [GHC]) $ + dieWithException verbosity $ + NoCompilerSupport (show comp) + where + comp = compiler lbi + + -- Check if all the install dirs are relative to same prefix + packagePrefixRelative = + unless (relativeInstallDirs installDirs) $ + dieWithException verbosity $ + InstallDirsNotPrefixRelative (installDirs) + where + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + relativeInstallDirs (InstallDirs{..}) = + all + isJust + ( fmap + (stripPrefix p) + [ bindir + , libdir + , dynlibdir + , libexecdir + , includedir + , datadir + , docdir + , mandir + , htmldir + , haddockdir + , sysconfdir + ] + ) + + -- Check if the library dirs of the dependencies that are in the package + -- database to which the package is installed are relative to the + -- prefix of the package + depsPrefixRelative = do + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) + traverse_ (doCheck $ getSymbolicPath pkgr) ipkgs + where + doCheck pkgr ipkg + | maybe False (== pkgr) (IPI.pkgRoot ipkg) = + for_ (IPI.libraryDirs ipkg) $ \libdir -> do + -- When @prefix@ is not under @pkgroot@, + -- @shortRelativePath prefix pkgroot@ will return a path with + -- @..@s and following check will fail without @canonicalizePath@. + canonicalized <- canonicalizePath libdir + -- The @prefix@ itself must also be canonicalized because + -- canonicalizing @libdir@ may expand symlinks which would make + -- @prefix@ no longer being a prefix of @canonical libdir@, + -- while @canonical p@ could be a prefix of @canonical libdir@ + p' <- canonicalizePath p + unless (p' `isPrefixOf` canonicalized) $ + dieWithException verbosity $ + LibDirDepsPrefixNotRelative libdir p + | otherwise = + return () + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + ipkgs = PackageIndex.allPackages (installedPkgs lbi) + +-- ----------------------------------------------------------------------------- +-- Testing foreign library requirements + +unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] +unsupportedForeignLibs comp platform = + mapMaybe (checkForeignLibSupported comp platform) + +checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String +checkForeignLibSupported comp platform flib = go (compilerFlavor comp) + where + go :: CompilerFlavor -> Maybe String + go GHC + | compilerVersion comp < mkVersion [7, 8] = + unsupported + [ "Building foreign libraries is only supported with GHC >= 7.8" + ] + | otherwise = goGhcPlatform platform + go _ = + unsupported + [ "Building foreign libraries is currently only supported with ghc" + ] + + goGhcPlatform :: Platform -> Maybe String + goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib) + goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform _ FreeBSD) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform _ = + unsupported + [ "Building foreign libraries is currently only supported on Mac OS, " + , "Linux and Windows" + ] + + goGhcOsx :: ForeignLibType -> Maybe String + goGhcOsx ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on OSX" + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on OSX" + ] + | otherwise = + Nothing + goGhcOsx _ = + unsupported + [ "We can currently only build shared foreign libraries on OSX" + ] + + goGhcLinux :: ForeignLibType -> Maybe String + goGhcLinux ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on Linux" + ] + | not (null (foreignLibVersionInfo flib)) + && not (null (foreignLibVersionLinux flib)) = + unsupported + [ "You must not specify both lib-version-info and lib-version-linux" + ] + | otherwise = + Nothing + goGhcLinux _ = + unsupported + [ "We can currently only build shared foreign libraries on Linux" + ] + + goGhcWindows :: ForeignLibType -> Maybe String + goGhcWindows ForeignLibNativeShared + | not standalone = + unsupported + [ "We can currently only build standalone libraries on Windows. Use\n" + , " if os(Windows)\n" + , " options: standalone\n" + , "in your foreign-library stanza." + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on Windows.\n" + , "You can specify module definition files in the mod-def-file field." + ] + | otherwise = + Nothing + goGhcWindows _ = + unsupported + [ "We can currently only build shared foreign libraries on Windows" + ] + + standalone :: Bool + standalone = ForeignLibStandalone `elem` foreignLibOptions flib + + unsupported :: [String] -> Maybe String + unsupported = Just . concat 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Flag.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Flag +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines the 'Flag' type and it's 'Monoid' instance, see +-- +-- for an explanation. +-- +-- Split off from "Distribution.Simple.Setup" to break import cycles. +module Distribution.Simple.Flag + ( Flag + , pattern Flag + , pattern NoFlag + , allFlags + , toFlag + , fromFlag + , fromFlagOrDefault + , flagElim + , flagToMaybe + , flagToList + , maybeToFlag + , mergeListFlag + , BooleanFlag (..) + ) where + +import Data.Monoid (Last (..)) +import Distribution.Compat.Prelude hiding (get) +import Distribution.Compat.Stack +import Prelude () + +-- ------------------------------------------------------------ + +-- * Flag type + +-- ------------------------------------------------------------ + +-- | All flags are monoids, they come in two flavours: +-- +-- 1. list flags eg +-- +-- > --ghc-option=foo --ghc-option=bar +-- +-- gives us all the values ["foo", "bar"] +-- +-- 2. singular value flags, eg: +-- +-- > --enable-foo --disable-foo +-- +-- gives us Just False +-- +-- So, this 'Flag' type is for the latter singular kind of flag. +-- Its monoid instance gives us the behaviour where it starts out as +-- 'NoFlag' and later flags override earlier ones. +-- +-- Isomorphic to 'Maybe' a. +type Flag = Last + +pattern Flag :: a -> Last a +pattern Flag a = Last (Just a) + +pattern NoFlag :: Last a +pattern NoFlag = Last Nothing + +{-# COMPLETE Flag, NoFlag #-} + +-- | Wraps a value in 'Flag'. +toFlag :: a -> Flag a +toFlag = Flag + +-- | Extracts a value from a 'Flag', and throws an exception on 'NoFlag'. +fromFlag :: WithCallStack (Flag a -> a) +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" + +-- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'. +fromFlagOrDefault :: a -> Flag a -> a +fromFlagOrDefault def = fromMaybe def . getLast + +-- | Converts a 'Flag' value to a 'Maybe' value. +flagToMaybe :: Flag a -> Maybe a +flagToMaybe = getLast + +-- | Pushes a function through a 'Flag' value, and returns a default +-- if the 'Flag' value is 'NoFlag'. +-- +-- @since 3.4.0.0 +flagElim :: b -> (a -> b) -> Flag a -> b +flagElim n f = maybe n f . getLast + +-- | Converts a 'Flag' value to a list. +flagToList :: Flag a -> [a] +flagToList = maybeToList . getLast + +-- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'. +allFlags :: [Flag Bool] -> Flag Bool +allFlags flags = + if all (\f -> fromFlagOrDefault False f) flags + then Flag True + else NoFlag + +-- | Converts a 'Maybe' value to a 'Flag' value. +maybeToFlag :: Maybe a -> Flag a +maybeToFlag = Last + +-- | Merge the elements of a list 'Flag' with another list 'Flag'. +mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] +mergeListFlag currentFlags v = + Flag $ concat (flagToList currentFlags ++ flagToList v) + +-- | Types that represent boolean flags. +class BooleanFlag a where + asBool :: a -> Bool + +instance BooleanFlag Bool where + asBool = id diff --git a/src/Distribution/Simple/GHC.hs b/src/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC.hs @@ -0,0 +1,1166 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. +module Distribution.Simple.GHC + ( getGhcInfo + , configure + , configureCompiler + , compilerProgramDb + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , Internal.componentGhcOptions + , Internal.componentCcGhcOptions + , getGhcAppDir + , getLibDir + , compilerBuildWay + , getGlobalPackageDB + , pkgRoot + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Arrow ((***)) +import Control.Monad (forM_) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Distribution.CabalSpecVersion +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..)) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import qualified Distribution.Simple.GHC.Build as GHC +import Distribution.Simple.GHC.Build.Modules (BuildWay (..)) +import Distribution.Simple.GHC.Build.Utils +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (runghcProgram) +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Repl +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.FilePath + ( isRelative + , takeDirectory + ) +import qualified System.Info +#ifndef mingw32_HOST_OS +import System.Posix (createSymbolicLink) +#endif /* mingw32_HOST_OS */ + +{- FOURMOLU_DISABLE -} +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getAppUserDataDirectory + , getDirectoryContents +#ifndef mingw32_HOST_OS + , renameFile +#endif + ) +{- FOURMOLU_ENABLE -} + +import Distribution.Simple.Setup (BuildingWhat (..)) +import Distribution.Simple.Setup.Build + +-- ----------------------------------------------------------------------------- +-- Configuring + +-- | Configure GHC, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. +configure + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHC. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do + (ghcProg, ghcVersion, progdb1) <- + requireProgramVersion + verbosity + ghcProgram + (orLaterVersion (mkVersion [7, 0, 1])) + (userMaybeSpecifyPath "ghc" hcPath conf0) + + -- Cabal currently supports GHC less than `maxGhcVersion` + let maxGhcVersion = mkVersion [9, 16] + unless (ghcVersion < maxGhcVersion) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < " + ++ prettyShow maxGhcVersion + ++ "): " + ++ programPath ghcProg + ++ " is version " + ++ prettyShow ghcVersion + + let implInfo = ghcVersionImplInfo ghcVersion + languages <- Internal.getLanguages verbosity implInfo ghcProg + extensions0 <- Internal.getExtensions verbosity implInfo ghcProg + + ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg + + let ghcInfoMap = Map.fromList ghcInfo + filterJS = if ghcVersion < mkVersion [9, 8] then filterExt JavaScriptFFI else id + extensions = + -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 + filterJS $ + -- see 'filterExtTH' comment below + filterExtTH $ + extensions0 + + -- starting with GHC 8.0, `TemplateHaskell` will be omitted from + -- `--supported-extensions` when it's not available. + -- for older GHCs we can use the "Have interpreter" property to + -- filter out `TemplateHaskell` + filterExtTH + | ghcVersion < mkVersion [8] + , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap = + filterExt TemplateHaskell + | otherwise = id + + filterExt ext = filter ((/= EnableExtension ext) . fst) + + compilerId :: CompilerId + compilerId = CompilerId GHC ghcVersion + + -- The @AbiTag@ is the @Project Unit Id@ but with redundant information from the compiler version removed. + -- For development versions of the compiler these look like: + -- @Project Unit Id@: "ghc-9.13-inplace" + -- @compilerId@: "ghc-9.13.20250413" + -- So, we need to be careful to only strip the /common/ prefix. + -- In this example, @AbiTag@ is "inplace". + compilerAbiTag :: AbiTag + compilerAbiTag = + maybe + NoAbiTag + AbiTag + ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId) + <$> Map.lookup "Project Unit Id" ghcInfoMap + ) + + let comp = + Compiler + { compilerId + , compilerAbiTag + , compilerCompat = [] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcInfo + return (comp, compPlatform, progdb1) + +-- | Given a configured @ghc@ program, configure auxiliary programs such +-- as @ghc-pkg@ or @haddock@, as well as toolchain programs such as @ar@, @ld@, +-- based on: +-- +-- - the location of the @ghc@ executable, +-- - toolchain information in the GHC settings file. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcProg = fromJust $ lookupProgram ghcProgram progdb1 + ghcVersion = compilerVersion comp + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, progdb2) <- + requireProgramVersion + verbosity + ghcPkgProgram + { programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion + (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) + + when (ghcVersion /= ghcPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = + haddockProgram + { programFindLocation = guessHaddockFromGhcPath ghcProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcPath ghcProg + } + runghcProgram' = + runghcProgram + { programFindLocation = guessRunghcFromGhcPath ghcProg + } + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + addKnownProgram runghcProgram' progdb2 + + -- configure gcc, ld, ar etc... based on the paths stored + -- in the GHC settings file + progdb4 = + Internal.configureToolchain + (ghcVersionImplInfo ghcVersion) + ghcProg + (compilerProperties comp) + progdb3 + return progdb4 + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find +-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking +-- for a versioned or unversioned ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +guessToolFromGhcPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcPath tool ghcProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcVersioned dir suf = + dir + (toolname ++ "-ghc" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessNormal dir] + | otherwise = + [ guessGhcVersioned dir suf + , guessVersioned dir suf + , guessNormal dir + ] + -- order matters here, see https://github.com/haskell/cabal/issues/7390 + guesses = + ( if real_path == given_path + then [] + else mkGuesses real_dir real_suf + ) + ++ mkGuesses given_dir given_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +guessGhcPkgFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +guessHsc2hsFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding haddock, we try looking for both a versioned and unversioned +-- haddock in the same dir, that is: +-- +-- > /usr/local/bin/haddock-ghc-6.6.1(.exe) +-- > /usr/local/bin/haddock-6.6.1(.exe) +-- > /usr/local/bin/haddock(.exe) +guessHaddockFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram + +guessHpcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram + +guessRunghcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg + where + version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity mbWorkDir packagedb progdb = do + pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity comp packagedbs + pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! hackRtsPackage index + where + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] -> + PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc test suite does some crazy stuff. + +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a +-- @PackageIndex@. Helper function used by 'getPackageDBContents' and +-- 'getInstalledPackages'. +toPackageIndex + :: Verbosity + -> [(PackageDBX a, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcProg + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] + return $! mconcat indices + where + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- | Return the 'FilePath' to the GHC application data directory. +-- +-- @since 3.4.0.0 +getGhcAppDir :: IO FilePath +getGhcAppDir = getAppUserDataDirectory "ghc" + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcProgram + (withPrograms lbi) + ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB + :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getGhcAppDir + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcVersion + packageConfFileName = "package.conf.d" + ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" + +checkPackageDbStack :: Eq fp => Verbosity -> Compiler -> PackageDBStackX fp -> IO () +checkPackageDbStack verbosity comp = + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity + where + implInfo = ghcVersionImplInfo (compilerVersion comp) + +checkPackageDbStackPost76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStackPost76 _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPost76 verbosity rest + | GlobalPackageDB `elem` rest = + dieWithException verbosity CheckPackageDbStackPost76 +checkPackageDbStackPost76 _ _ = return () + +checkPackageDbStackPre76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStackPre76 _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPre76 verbosity rest + | GlobalPackageDB `notElem` rest = + dieWithException verbosity CheckPackageDbStackPre76 +checkPackageDbStackPre76 verbosity _ = + dieWithException verbosity GlobalPackageDbSpecifiedFirst + +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg{InstalledPackageInfo.includeDirs = ids'} + +-- | Get the packages from specific PackageDBs, not cumulative. +getInstalledPackages' + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> [PackageDBX (SymbolicPath from (Dir PkgDB))] + -> ProgramDb + -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])] +getInstalledPackages' verbosity mbWorkDir packagedbs progdb = + sequenceA + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +getInstalledPackagesMonitorFiles + :: forall from + . Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> Platform + -> ProgramDb + -> [PackageDBS from] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity mbWorkDir platform progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDBS from -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path0 = do + let path = + if isRelative path0 + then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0) + else path0 + isFileStyle <- doesFileExist path + if isFileStyle + then return path + else return (path "package.cache") + + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildNormal flags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CLib lib) + } + +replLib + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildRepl flags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CLib lib) + } + +-- | Start a REPL without loading any source files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity comp packageDBs + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb + -- This doesn't pass source file arguments to GHC, so we don't have to worry + -- about using a response file here. + runGHC verbosity ghcProg comp platform Nothing replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib v numJobs pkg lbi flib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs + { buildingWhat = + BuildNormal $ + mempty + { buildCommonFlags = + mempty{setupVerbosity = toFlag v} + } + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CFLib flib) + } + +replFLib + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags njobs pkg lbi flib clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildRepl replFlags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CFLib flib) + } + +-- | Build an executable with GHC. +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe v njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs + { buildingWhat = + BuildNormal $ + mempty + { buildCommonFlags = + mempty{setupVerbosity = toFlag v} + } + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CExe exe) + } + +replExe + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe replFlags njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildRepl replFlags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CExe exe) + } + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +libAbiHash + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + mbWorkDir = mbWorkDirLBI lbi + vanillaArgs = + (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcProfOptions GHC libBi + } + profDynArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "p_dyn_hi" + , ghcOptObjSuffix = toFlag "p_dyn_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcProfSharedOptions GHC libBi + } + ghcArgs = + let (libWays, _, _) = buildWays lbi + in case libWays (componentIsIndefinite clbi) of + (ProfDynWay : _) -> profDynArgs + (ProfWay : _) -> profArgs + (StaticWay : _) -> vanillaArgs + (DynWay : _) -> sharedArgs + _ -> error "libAbiHash: Can't find an enabled library way" + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + + hash <- + getProgramInvocationOutput + verbosity + =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir ghcArgs + + return (takeWhile (not . isSpace) hash) + +-- ----------------------------------------------------------------------------- +-- Installing + +-- | Install executables for GHC. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeTargetName (hostPlatform lbi) (exeName exe) + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + installExecutableFile + verbosity + (buildPref exeName' exeFileName) + (dest <.> exeExtension (hostPlatform lbi)) + when (stripExes lbi) $ + Strip.stripExe + verbosity + (hostPlatform lbi) + (withPrograms lbi) + (dest <.> exeExtension (hostPlatform lbi)) + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + -- TODO: Should we strip? (stripLibs lbi) + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + -- Now install appropriate symlinks if library is versioned + let (Platform _ os) = hostPlatform lbi + when (not (null (foreignLibVersion flib os))) $ do + when (os /= Linux) $ + dieWithException verbosity $ + CantInstallForeignLib +#ifndef mingw32_HOST_OS + -- 'createSymbolicLink file1 file2' creates a symbolic link + -- named 'file2' which points to the file 'file1'. + -- Note that we do want a symlink to 'name' rather than + -- 'dst', because the symlink will be relative to the + -- directory it's created in. + -- Finally, we first create the symlinks in a temporary + -- directory and then rename to simulate 'ln --force'. + withTempDirectory verbosity dstDir nm $ \tmpDir -> do + let link1 = flibBuildName lbi flib + link2 = "lib" ++ nm <.> "so" + createSymbolicLink name (tmpDir link1) + renameFile (tmpDir link1) (dstDir link1) + createSymbolicLink name (tmpDir link2) + renameFile (tmpDir link2) (dstDir link2) + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib +#endif /* mingw32_HOST_OS */ + +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do + let + (wantedLibWays, _, _) = buildWays lbi + isIndef = componentIsIndefinite clbi + libWays = wantedLibWays isIndef + + info verbosity ("Wanted install ways: " ++ show libWays) + + -- copy .hi files over: + forM_ (wantedLibWays isIndef) $ \w -> case w of + StaticWay -> copyModuleFiles (Suffix "hi") + DynWay -> copyModuleFiles (Suffix "dyn_hi") + ProfWay -> copyModuleFiles (Suffix "p_hi") + ProfDynWay -> copyModuleFiles (Suffix "p_dyn_hi") + + -- copy extra compilation artifacts that ghc plugins may produce + copyDirectoryIfExists extraCompilationArtifacts + + -- copy the built library files over: + when (has_code && hasLib) $ do + forM_ libWays $ \w -> case w of + StaticWay -> do + sequence_ + [ installOrdinary + builtDir + targetDir + (mkGenericStaticLibName (l ++ f)) + | l <- + getHSLibraryName + (componentUnitId clbi) + : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + ProfWay -> do + installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName + ProfDynWay -> do + installShared + builtDir + dynlibTargetDir + (mkProfSharedLibName platform compiler_id uid) + DynWay -> do + if + -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. + -- See ghc issue #15837 and Cabal PR #5855. + | specVersion pkg < CabalSpecV3_0 -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + (mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + | otherwise -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + ( mkGenericSharedLibName + platform + compiler_id + (getHSLibraryName uid ++ f) + ) + | f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + sequence_ + [ do + files <- getDirectoryContents (i builtDir) + let l' = + mkGenericSharedBundledLibName + platform + compiler_id + (l ++ f) + forM_ files $ \file -> + when (l' `isPrefixOf` file) $ do + isFile <- doesFileExist (i $ builtDir makeRelativePathEx file) + when isFile $ do + installShared + builtDir + dynlibTargetDir + file + | l <- extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + + builtDir = componentBuildDir lbi clbi + mbWorkDir = mbWorkDirLBI lbi + + install isShared srcDir dstDir name = do + let src = i $ srcDir makeRelativePathEx name + dst = dstDir name + + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi) $ + Strip.stripLib + verbosity + platform + (withPrograms lbi) + dst + + installOrdinary = install False + installShared = install True + + copyModuleFiles ext = do + files <- findModuleFilesCwd verbosity mbWorkDir [builtDir] [ext] (allLibModules lib clbi) + let files' = map (i *** getSymbolicPath) files + installOrdinaryFiles verbosity targetDir files' + + copyDirectoryIfExists :: RelativePath Build (Dir Artifacts) -> IO () + copyDirectoryIfExists dirName = do + let src = i $ builtDir dirName + dst = targetDir getSymbolicPath dirName + dirExists <- doesDirectoryExist src + when dirExists $ copyDirectoryRecursive verbosity src dst + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + profileLibName = mkProfLibName uid + ghciLibName = Internal.mkGHCiLibName uid + ghciProfLibName = Internal.mkGHCiProfLibName uid + + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (cmmSources (libBuildInfo lib)) + && null (asmSources (libBuildInfo lib)) + && (null (jsSources (libBuildInfo lib)) || not hasJsSupport) + hasJsSupport = case hostPlatform lbi of + Platform JavaScript _ -> True + _ -> False + has_code = not (componentIsIndefinite clbi) + whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo progdb = + HcPkg.HcPkgInfo + { HcPkg.hcPkgProgram = ghcPkgProg + , HcPkg.noPkgDbStack = v < [6, 9] + , HcPkg.noVerboseFlag = v < [6, 11] + , HcPkg.flagPackageConf = v < [7, 5] + , HcPkg.supportsDirDbs = v >= [6, 8] + , HcPkg.requiresDirDbs = v >= [7, 10] + , HcPkg.nativeMultiInstance = v >= [7, 10] + , HcPkg.recacheMultiInstance = v >= [6, 12] + , HcPkg.suppressFilesCheck = v >= [6, 6] + } + where + v = versionNumbers ver + ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb + ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg + +registerPackage + :: Verbosity + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions = + HcPkg.register + (hcPkgInfo progdb) + verbosity + mbWorkDir + packageDbs + installedPkgInfo + registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO (SymbolicPath CWD (Dir Pkg)) +pkgRoot verbosity lbi = fmap makeSymbolicPath . pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) + pkgRoot' UserPackageDB = do + appDir <- getGhcAppDir + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exist. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = + return $ + takeDirectory $ + interpretSymbolicPathLBI lbi fp 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/EnvironmentParser.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Compiler +import Distribution.Simple.GHC.Internal + ( GhcEnvironmentFileEntry (..) + ) +import Distribution.Types.UnitId + ( mkUnitId + ) + +import qualified Text.Parsec as P +import Text.Parsec.String + ( Parser + , parseFromFile + ) + +parseEnvironmentFileLine :: Parser (GhcEnvironmentFileEntry FilePath) +parseEnvironmentFileLine = + GhcEnvFileComment <$> comment + <|> GhcEnvFilePackageId <$> unitId + <|> GhcEnvFilePackageDb <$> packageDb + <|> pure GhcEnvFileClearPackageDbStack <* clearDb + where + comment = P.string "--" *> P.many (P.noneOf "\r\n") + unitId = + P.try $ + P.string "package-id" + *> P.spaces + *> (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) + packageDb = + (P.string "global-package-db" *> pure GlobalPackageDB) + <|> (P.string "user-package-db" *> pure UserPackageDB) + <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) + clearDb = P.string "clear-package-db" + +newtype ParseErrorExc = ParseErrorExc P.ParseError + deriving (Show) + +instance Exception ParseErrorExc + +parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry FilePath] +parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof + +readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry FilePath] +readGhcEnvironmentFile path = + either (throwIO . ParseErrorExc) return + =<< parseFromFile parseGhcEnvironmentFile path diff --git a/src/Distribution/Simple/GHC/ImplInfo.hs b/src/Distribution/Simple/GHC/ImplInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/ImplInfo.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.GHC.ImplInfo +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains the data structure describing invocation +-- details for a GHC or GHC-derived compiler, such as supported flags +-- and workarounds for bugs. +module Distribution.Simple.GHC.ImplInfo + ( GhcImplInfo (..) + , getImplInfo + , ghcVersionImplInfo + , ghcjsVersionImplInfo + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Compiler +import Distribution.Version + +-- | +-- Information about features and quirks of a GHC-based implementation. +-- +-- Compiler flavors based on GHC behave similarly enough that some of +-- the support code for them is shared. Every implementation has its +-- own peculiarities, that may or may not be a direct result of the +-- underlying GHC version. This record keeps track of these differences. +-- +-- All shared code (i.e. everything not in the Distribution.Simple.FLAVOR +-- module) should use implementation info rather than version numbers +-- to test for supported features. +data GhcImplInfo = GhcImplInfo + { supportsHaskell2010 :: Bool + -- ^ -XHaskell2010 and -XHaskell98 flags + , supportsGHC2021 :: Bool + -- ^ -XGHC2021 flag + , supportsGHC2024 :: Bool + -- ^ -XGHC2024 flag + , reportsNoExt :: Bool + -- ^ --supported-languages gives Ext and NoExt + , alwaysNondecIndent :: Bool + -- ^ NondecreasingIndentation is always on + , flagGhciScript :: Bool + -- ^ -ghci-script flag supported + , flagProfAuto :: Bool + -- ^ new style -fprof-auto* flags + , flagProfLate :: Bool + -- ^ fprof-late flag + , flagPackageConf :: Bool + -- ^ use package-conf instead of package-db + , flagDebugInfo :: Bool + -- ^ -g flag supported + , flagHie :: Bool + -- ^ -hiedir flag supported + , supportsDebugLevels :: Bool + -- ^ supports numeric @-g@ levels + , supportsPkgEnvFiles :: Bool + -- ^ picks up @.ghc.environment@ files + , flagWarnMissingHomeModules :: Bool + -- ^ -Wmissing-home-modules is supported + , unitIdForExes :: Bool + -- ^ Pass -this-unit-id flag when building executables + } + +getImplInfo :: Compiler -> GhcImplInfo +getImplInfo comp = + case compilerFlavor comp of + GHC -> ghcVersionImplInfo (compilerVersion comp) + GHCJS -> case compilerCompatVersion GHC comp of + Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer + _ -> + error + ( "Distribution.Simple.GHC.Props.getImplProps: " + ++ "could not find GHC version for GHCJS compiler" + ) + x -> + error + ( "Distribution.Simple.GHC.Props.getImplProps only works" + ++ "for GHC-like compilers (GHC, GHCJS)" + ++ ", but found " + ++ show x + ) + +ghcVersionImplInfo :: Version -> GhcImplInfo +ghcVersionImplInfo ver = + GhcImplInfo + { supportsHaskell2010 = v >= [7] + , supportsGHC2021 = v >= [9, 1] + , supportsGHC2024 = v >= [9, 9] + , reportsNoExt = v >= [7] + , alwaysNondecIndent = v < [7, 1] + , flagGhciScript = v >= [7, 2] + , flagProfAuto = v >= [7, 4] + , flagProfLate = v >= [9, 4] + , flagPackageConf = v < [7, 5] + , flagDebugInfo = v >= [7, 10] + , flagHie = v >= [8, 8] + , supportsDebugLevels = v >= [8, 0] + , supportsPkgEnvFiles = v >= [8, 0, 1, 20160901] -- broken in 8.0.1, fixed in 8.0.2 + , flagWarnMissingHomeModules = v >= [8, 2] + , unitIdForExes = v >= [9, 2] + } + where + v = versionNumbers ver + +ghcjsVersionImplInfo + :: Version + -- ^ The GHCJS version + -> Version + -- ^ The GHC version + -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsver ghcver = + GhcImplInfo + { supportsHaskell2010 = True + , supportsGHC2021 = True + , supportsGHC2024 = ghcv >= [9, 9] + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagProfAuto = True + , flagProfLate = True + , flagPackageConf = False + , flagDebugInfo = False + , flagHie = ghcv >= [8, 8] + , supportsDebugLevels = ghcv >= [8, 0] + , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs + , flagWarnMissingHomeModules = ghcv >= [8, 2] + , unitIdForExes = ghcv >= [9, 2] + } + where + ghcv = versionNumbers ghcver diff --git a/src/Distribution/Simple/GHC/Internal.hs b/src/Distribution/Simple/GHC/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Internal.hs @@ -0,0 +1,864 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.GHC.Internal +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains functions shared by GHC (Distribution.Simple.GHC) +-- and GHC-derived compilers. +module Distribution.Simple.GHC.Internal + ( configureToolchain + , getLanguages + , getExtensions + , targetPlatform + , getGhcInfo + , componentCcGhcOptions + , componentCmmGhcOptions + , componentCxxGhcOptions + , componentAsmGhcOptions + , componentJsGhcOptions + , componentGhcOptions + , mkGHCiLibName + , mkGHCiProfLibName + , filterGhciFlags + , ghcLookupProperty + , getHaskellObjects + , mkGhcOptPackages + , substTopDir + , checkPackageDbEnvVar + , profDetailLevelFlag + + -- * GHC platform and version strings + , ghcArchString + , ghcOsString + , ghcPlatformAndVersionString + + -- * Constructing GHC environment files + , GhcEnvironmentFileEntry (..) + , writeGhcEnvironmentFile + , simpleGhcEnvironmentFile + , ghcEnvironmentFileName + , renderGhcEnvironmentFile + , renderGhcEnvironmentFileEntry + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.Bool (bool) +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Backpack +import Distribution.Compat.Stack +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Lex +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag (Flag, maybeToFlag, toFlag, pattern NoFlag) +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup.Common (extraCompilationArtifacts) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.GivenComponent +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Utils.NubList (NubListR, toNubListR) +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version (Version) +import Language.Haskell.Extension +import System.Directory (getDirectoryContents) +import System.Environment (getEnv) +import System.FilePath + ( takeDirectory + , takeExtension + , takeFileName + ) +import System.IO (hClose, hPutStrLn) + +targetPlatform :: [(String, String)] -> Maybe Platform +targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo + +-- | Adjust the way we find and configure gcc and ld +configureToolchain + :: GhcImplInfo + -> ConfiguredProgram + -> Map String String + -> ProgramDb + -> ProgramDb +configureToolchain _implInfo ghcProg ghcInfo = + addKnownProgram + gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + . addKnownProgram + gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + . addKnownProgram + ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd v =<< programPostConf ldProgram v cp + } + . addKnownProgram + arProgram + { programFindLocation = findProg arProgramName extraArPath + } + . addKnownProgram + stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } + where + compilerDir, base_dir, mingwBinDir :: FilePath + compilerDir = takeDirectory (programPath ghcProg) + base_dir = takeDirectory compilerDir + mingwBinDir = base_dir "mingw" "bin" + isWindows = case buildOS of Windows -> True; _ -> False + binPrefix = "" + + maybeName :: Program -> Maybe FilePath -> String + maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) + + gccProgramName = maybeName gccProgram mbGccLocation + gppProgramName = maybeName gppProgram mbGppLocation + ldProgramName = maybeName ldProgram mbLdLocation + arProgramName = maybeName arProgram mbArLocation + stripProgramName = maybeName stripProgram mbStripLocation + + mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] + mkExtraPath mbPath mingwPath + | isWindows = mbDir ++ [mingwPath] + | otherwise = mbDir + where + mbDir = maybeToList . fmap takeDirectory $ mbPath + + extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraGppPath = mkExtraPath mbGppLocation windowsExtraGppDir + extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir + extraArPath = mkExtraPath mbArLocation windowsExtraArDir + extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir + + -- on Windows finding and configuring ghc's gcc & binutils is a bit special + ( windowsExtraGccDir + , windowsExtraGppDir + , windowsExtraLdDir + , windowsExtraArDir + , windowsExtraStripDir + ) = + let b = mingwBinDir binPrefix + in (b, b, b, b, b) + + findProg + :: String + -> [FilePath] + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + findProg progName extraPath v searchpath = + findProgramOnSearchPath v searchpath' progName + where + searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath + + -- Read tool locations from the 'ghc --info' output. Useful when + -- cross-compiling. + mbGccLocation = Map.lookup "C compiler command" ghcInfo + mbGppLocation = Map.lookup "C++ compiler command" ghcInfo + mbLdLocation = Map.lookup "ld command" ghcInfo + mbArLocation = Map.lookup "ar command" ghcInfo + mbStripLocation = Map.lookup "strip command" ghcInfo + + ccFlags = getFlags "C compiler flags" + cxxFlags = getFlags "C++ compiler flags" + -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" + -- and "Ld Linker flags" to "ld flags" (GHC #4862). + gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" + ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" + + -- It appears that GHC 7.6 and earlier encode the tokenized flags as a + -- [String] in these settings whereas later versions just encode the flags as + -- String. + -- + -- We first try to parse as a [String] and if this fails then tokenize the + -- flags ourself. + getFlags :: String -> [String] + getFlags key = + case Map.lookup key ghcInfo of + Nothing -> [] + Just flags + | (flags', "") : _ <- reads flags -> flags' + | otherwise -> tokenizeQuotedWords flags + + configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc _v gccProg = do + return + gccProg + { programDefaultArgs = + programDefaultArgs gccProg + ++ ccFlags + ++ gccLinkerFlags + } + + configureGpp :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGpp _v gppProg = do + return + gppProg + { programDefaultArgs = + programDefaultArgs gppProg + ++ cxxFlags + } + + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd v ldProg = do + ldProg' <- configureLd' v ldProg + return + ldProg' + { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags + } + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' verbosity ldProg = do + ldx <- withTempFile ".c" $ \testcfile testchnd -> + withTempFile ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd + hClose testohnd + runProgram + verbosity + ghcProg + [ "-hide-all-packages" + , "-c" + , testcfile + , "-o" + , testofile + ] + withTempFile ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- + getProgramOutput + verbosity + ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ldProg{programDefaultArgs = ["-x"]} + else return ldProg + +getLanguages + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Language, String)] +getLanguages _ implInfo _ + -- TODO: should be using --supported-languages rather than hard coding + | supportsGHC2024 implInfo = + return + [ (GHC2024, "-XGHC2024") + , (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsGHC2021 implInfo = + return + [ (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsHaskell2010 implInfo = + return + [ (Haskell98, "-XHaskell98") + , (Haskell2010, "-XHaskell2010") + ] + | otherwise = return [(Haskell98, "")] + +getGhcInfo + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(String, String)] +getGhcInfo verbosity _implInfo ghcProg = do + xs <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + dieWithException verbosity CantParseGHCOutput + +getExtensions + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Extension, Maybe String)] +getExtensions verbosity implInfo ghcProg = do + str <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--supported-languages"] + let extStrs = + if reportsNoExt implInfo + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = + [ (ext, Just $ "-X" ++ prettyShow ext) + | Just ext <- map simpleParsec extStrs + ] + extensions1 = + if alwaysNondecIndent implInfo + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + -- Since it was not a proper extension, it could + -- not be turned off, hence we omit a + -- DisableExtension entry here. + + (EnableExtension NondecreasingIndentation, Nothing) + : extensions0 + else extensions0 + return extensions1 + +includePaths + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg p + -> NubListR (SymbolicPath Pkg (Dir Include)) +includePaths lbi bi clbi odir = + toNubListR $ + [ coerceSymbolicPath $ autogenComponentModulesDir lbi clbi + , coerceSymbolicPath $ autogenPackageModulesDir lbi + , coerceSymbolicPath odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [ buildDir lbi dir + | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi + ] + +componentCcGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentCcGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptCcOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ ccOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentCxxGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentCxxGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptCxxOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ cxxOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentAsmGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentAsmGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptAsmOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ asmOptions bi + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentJsGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentJsGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptJSppOptions = jsppOptions bi + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir build) + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let implInfo = getImplInfo $ compiler lbi + in mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptCabal = toFlag True + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ | not (unitIdForExes implInfo) -> mempty + ExeComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + TestComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + BenchComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + FLibComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentComponentId = cid + , componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag cid + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptNoCode = toFlag $ componentIsIndefinite clbi + , ghcOptHideAllPackages = toFlag True + , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi + , ghcOptSplitSections = toFlag (splitSections lbi) + , ghcOptSplitObjs = toFlag (splitObjs lbi) + , ghcOptSourcePathClear = toFlag True + , ghcOptSourcePath = + toNubListR $ + (hsSourceDirs bi) + ++ [coerceSymbolicPath odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptCppOptions = cppOptions bi + , ghcOptJSppOptions = jsppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [coerceSymbolicPath (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi + , ghcOptObjDir = toFlag $ coerceSymbolicPath odir + , ghcOptHiDir = toFlag $ coerceSymbolicPath odir + , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir (extraCompilationArtifacts makeRelativePathEx "hie")) $ flagHie implInfo + , ghcOptStubDir = toFlag $ coerceSymbolicPath odir + , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi + , ghcOptExtraPath = toNubListR exe_paths + , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) + , -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi + , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + } + where + exe_paths = + [ componentBuildDir lbi (targetCLBI exe_tgt) + | uid <- componentExeDeps clbi + , -- TODO: Ugh, localPkgDescr + Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] + ] + +toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation +toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override? +toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation +toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation + +componentCmmGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentCmmGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi + , ghcOptObjDir = toFlag odir + } + +-- | Strip out flags that are not supported in ghci +filterGhciFlags :: [String] -> [String] +filterGhciFlags = filter supported + where + supported ('-' : 'O' : _) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" + +mkGHCiProfLibName :: UnitId -> String +mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case Map.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects + :: GhcImplInfo + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> String + -> Bool + -> IO [SymbolicPath Pkg File] +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = + [ pref makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi + ] + objss <- traverse (getDirectoryContents . i) dirs + let objs = + [ dir makeRelativePathEx obj + | (objs', dir) <- zip objss dirs + , obj <- objs' + , let obj_ext = takeExtension obj + , '.' : wanted_obj_ext == obj_ext + ] + return objs + | otherwise = + return + [ pref makeRelativePathEx (ModuleName.toFilePath x <.> wanted_obj_ext) + | x <- allLibModules lib clbi + ] + where + i = interpretSymbolicPathLBI lbi + +-- | Create the required packaged arguments, but filtering out package arguments which +-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files, +-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that +-- in 99% of cases we will include the right `-package` so that the C file finds the right headers. +mkGhcOptPackages + :: Map (PackageName, ComponentName) PromisedComponent + -> ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages promisedPkgsMap clbi = + [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids + ] + where + -- Promised deps are going to be simple UnitIds + promised_cids = Set.fromList (map (newSimpleUnitId . promisedComponentId) (Map.elems promisedPkgsMap)) + +substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo +substTopDir topDir ipo = + ipo + { IPI.importDirs = map f (IPI.importDirs ipo) + , IPI.libraryDirs = map f (IPI.libraryDirs ipo) + , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo) + , IPI.includeDirs = map f (IPI.includeDirs ipo) + , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo) + , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo) + , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) + } + where + f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest + f x = x + +-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let +-- users know that this is the case. See ticket #335. Simply ignoring it is +-- not a good idea, since then ghc and cabal are looking at different sets +-- of package DBs and chaos is likely to ensue. +-- +-- An exception to this is when running cabal from within a `cabal exec` +-- environment. In this case, `cabal exec` will set the +-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set +-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow +-- GHC{,JS}_PACKAGE_PATH. +checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () +checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do + mPP <- lookupEnv packagePathEnvVar + when (isJust mPP) $ do + mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" + unless (mPP == mcsPP) abort + where + lookupEnv :: String -> IO (Maybe String) + lookupEnv name = + (Just `fmap` getEnv name) + `catchIO` const (return Nothing) + abort = + dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar + _ = callStack -- TODO: output stack when erroring + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault + | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailTopLate -> toFlag GhcProfLate + ProfDetailOther _ -> mempty + +-- ----------------------------------------------------------------------------- +-- GHC platform and version strings + +-- | GHC's rendering of its host or target 'Arch' as used in its platform +-- strings and certain file locations (such as user package db location). +ghcArchString :: Arch -> String +ghcArchString PPC = "powerpc" +ghcArchString PPC64 = "powerpc64" +ghcArchString PPC64LE = "powerpc64le" +ghcArchString other = prettyShow other + +-- | GHC's rendering of its host or target 'OS' as used in its platform +-- strings and certain file locations (such as user package db location). +ghcOsString :: OS -> String +ghcOsString Windows = "mingw32" +ghcOsString OSX = "darwin" +ghcOsString Solaris = "solaris2" +ghcOsString Hurd = "gnu" +ghcOsString other = prettyShow other + +-- | GHC's rendering of its platform and compiler version string as used in +-- certain file locations (such as user package db location). +-- For example @x86_64-linux-7.10.4@ +ghcPlatformAndVersionString :: Platform -> Version -> String +ghcPlatformAndVersionString (Platform arch os) version = + intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version] + +-- ----------------------------------------------------------------------------- +-- Constructing GHC environment files + +-- | The kinds of entries we can stick in a @.ghc.environment@ file. +data GhcEnvironmentFileEntry fp + = -- | @-- a comment@ + GhcEnvFileComment String + | -- | @package-id foo-1.0-4fe301a...@ + GhcEnvFilePackageId UnitId + | -- | @global-package-db@, + -- @user-package-db@ or + -- @package-db blah/package.conf.d/@ + GhcEnvFilePackageDb (PackageDBX fp) + | -- | @clear-package-db@ + GhcEnvFileClearPackageDbStack + deriving (Eq, Ord, Show) + +-- | Make entries for a GHC environment file based on a 'PackageDBStack' and +-- a bunch of package (unit) ids. +-- +-- If you need to do anything more complicated then either use this as a basis +-- and add more entries, or just make all the entries directly. +simpleGhcEnvironmentFile + :: PackageDBStackX fp + -> [UnitId] + -> [GhcEnvironmentFileEntry fp] +simpleGhcEnvironmentFile packageDBs pkgids = + GhcEnvFileClearPackageDbStack + : map GhcEnvFilePackageDb packageDBs + ++ map GhcEnvFilePackageId pkgids + +-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. +-- +-- The 'Platform' and GHC 'Version' are needed as part of the file name. +-- +-- Returns the name of the file written. +writeGhcEnvironmentFile + :: FilePath + -- ^ directory in which to put it + -> Platform + -- ^ the GHC target platform + -> Version + -- ^ the GHC version + -> [GhcEnvironmentFileEntry FilePath] + -- ^ the content + -> IO FilePath +writeGhcEnvironmentFile directory platform ghcversion entries = do + writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries + return envfile + where + envfile = directory ghcEnvironmentFileName platform ghcversion + +-- | The @.ghc.environment-$arch-$os-$ver@ file name +ghcEnvironmentFileName :: Platform -> Version -> FilePath +ghcEnvironmentFileName platform ghcversion = + ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion + +-- | Render a bunch of GHC environment file entries +renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry FilePath] -> String +renderGhcEnvironmentFile = + unlines . map renderGhcEnvironmentFileEntry + +-- | Render an individual GHC environment file entry +renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String +renderGhcEnvironmentFileEntry entry = case entry of + GhcEnvFileComment comment -> format comment + where + format = intercalate "\n" . map ("--" <++>) . lines + pref <++> "" = pref + pref <++> str = pref ++ " " ++ str + GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid + GhcEnvFilePackageDb pkgdb -> + case pkgdb of + GlobalPackageDB -> "global-package-db" + UserPackageDB -> "user-package-db" + SpecificPackageDB dbfile -> "package-db " ++ dbfile + GhcEnvFileClearPackageDbStack -> "clear-package-db" diff --git a/src/Distribution/Simple/GHCJS.hs b/src/Distribution/Simple/GHCJS.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHCJS.hs @@ -0,0 +1,2121 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.GHCJS + ( getGhcInfo + , configure + , configureCompiler + , compilerProgramDb + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , componentGhcOptions + , Internal.componentCcGhcOptions + , getLibDir + , isDynamic + , getGlobalPackageDB + , pkgRoot + , runCmd + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.PackageName.Magic +import Distribution.Types.ParStrat +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity (Verbosity) +import Distribution.Version + +import Control.Arrow ((***)) +import Control.Monad (msum) +import Data.Char (isLower) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , getAppUserDataDirectory + , removeFile + , renameFile + ) +import System.FilePath + ( isRelative + , replaceExtension + , takeDirectory + , takeExtension + ) +import qualified System.Info + +-- ----------------------------------------------------------------------------- +-- Configuring + +-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. +configure + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghcjs@ path (optional) + -> Maybe FilePath + -- ^ user-specified @ghcjs-pkg@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHCJS. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do + (ghcjsProg, ghcjsVersion, progdb1) <- + requireProgramVersion + verbosity + ghcjsProgram + (orLaterVersion (mkVersion [0, 1])) + (userMaybeSpecifyPath "ghcjs" hcPath conf0) + + Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) + unless (ghcjsGhcVersion < mkVersion [8, 8]) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < 8.8): " + ++ programPath ghcjsProg + ++ " is based on GHC version " + ++ prettyShow ghcjsGhcVersion + + let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + + languages <- Internal.getLanguages verbosity implInfo ghcjsProg + extensions <- Internal.getExtensions verbosity implInfo ghcjsProg + + ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg + let ghcInfoMap = Map.fromList ghcjsInfo + + let comp = + Compiler + { compilerId = CompilerId GHCJS ghcjsVersion + , compilerAbiTag = + AbiTag $ + "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) + , compilerCompat = [CompilerId GHC ghcjsGhcVersion] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcjsInfo + return (comp, compPlatform, progdb1) + +-- | Given a configured @ghcjs@ program, configure auxiliary programs such +-- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcjsProg = fromJust $ lookupProgram ghcjsProgram progdb1 + ghcjsVersion = compilerVersion comp + ghcjsGhcVersion = case compilerCompat comp of + [CompilerId GHC ghcjsGhcVer] -> ghcjsGhcVer + compat -> error $ "could not parse ghcjsGhcVersion:" ++ show compat + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- + requireProgramVersion + verbosity + ghcjsPkgProgram + { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg + } + anyVersion + (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) + + Just ghcjsPkgGhcjsVersion <- + findGhcjsPkgGhcjsVersion + verbosity + (programPath ghcjsPkgProg) + + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ + dieWithException verbosity $ + VersionMismatchJS + (programPath ghcjsProg) + ghcjsVersion + (programPath ghcjsPkgProg) + ghcjsPkgGhcjsVersion + + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion + + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = + guessHsc2hsFromGhcjsPath ghcjsProg + } + haddockProgram' = + haddockProgram + { programFindLocation = + guessHaddockFromGhcjsPath ghcjsProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcjsPath ghcjsProg + } + {- + runghcProgram' = runghcProgram { + programFindLocation = guessRunghcFromGhcjsPath ghcjsProg + } -} + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + {- addKnownProgram runghcProgram' -} progdb2 + + return progdb3 + +guessGhcjsPkgFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram + +guessHsc2hsFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram + +guessHaddockFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram + +guessHpcFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram + +guessToolFromGhcjsPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcjsProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcjs dir = + dir + (toolname ++ "-ghcjs") + <.> exeExtension buildPlatform + guessGhcjsVersioned dir suf = + dir + (toolname ++ "-ghcjs" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessGhcjs dir, guessNormal dir] + | otherwise = + [ guessGhcjsVersioned dir suf + , guessVersioned dir suf + , guessGhcjs dir + , guessNormal dir + ] + guesses = + mkGuesses given_dir given_suf + ++ if real_path == given_path + then [] + else mkGuesses real_dir real_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg + where + version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity mbWorkDir packagedb progdb = do + pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity mbWorkDir packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity packagedbs + pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! index + +toPackageIndex + :: Verbosity + -> [(PackageDBX a, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcjsProg + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] + return $! (mconcat indices) + where + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcjsProgram + (withPrograms lbi) + ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcjsProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcjsProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getAppUserDataDirectory "ghcjs" + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcjsVersion + packageConfFileName = "package.conf.d" + ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" + +checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStack _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack verbosity rest + | GlobalPackageDB `notElem` rest = + dieWithException verbosity GlobalPackageDBLimitation +checkPackageDbStack verbosity _ = + dieWithException verbosity GlobalPackageDBSpecifiedFirst + +getInstalledPackages' + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> [PackageDBX (SymbolicPath from (Dir PkgDB))] + -> ProgramDb + -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])] +getInstalledPackages' verbosity mbWorkDir packagedbs progdb = + sequenceA + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +-- | Get the packages from specific PackageDBs, not cumulative. +getInstalledPackagesMonitorFiles + :: Verbosity + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform mbWorkDir progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path0 = do + let path = + if isRelative path0 + then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0) + else path0 + isFileStyle <- doesFileExist path + if isFileStyle + then return path + else return (path "package.cache") + + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +toJSLibName :: String -> String +toJSLibName lib + | takeExtension lib `elem` [".dll", ".dylib", ".so"] = + replaceExtension lib "js_so" + | takeExtension lib == ".a" = replaceExtension lib "js_a" + | otherwise = lib <.> "js_a" + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib = buildOrReplLib Nothing + +replLib + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib = buildOrReplLib . Just + +buildOrReplLib + :: Maybe [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do + let uid = componentUnitId clbi + libTargetDir = componentBuildDir lbi clbi + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenStaticLib forceStatic = + when (forceStatic || withStaticLib lbi) + -- whenGHCiLib = when (withGHCiLib lbi) + forRepl = maybe False (const True) mReplFlags + -- ifReplLib = when forRepl + comp = compiler lbi + implInfo = getImplInfo comp + platform@(Platform _hostArch _hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) + mbWorkDir = mbWorkDirLBI lbi + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + u :: SymbolicPathX allowAbs Pkg to -> FilePath + u = getSymbolicPath + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir + + let libBi = libBuildInfo lib + + -- fixme flags shouldn't depend on ghcjs being dynamic or not + let isGhcjsDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = usesTemplateHaskellOrQQ libBi + forceVanillaLib = doingTH && not isGhcjsDynamic + forceSharedLib = doingTH && isGhcjsDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = libCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir (coerceSymbolicPath libTargetDir coerceSymbolicPath extraCompilationArtifacts) way + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True $ i libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + jsSrcs = jsSources libBi + cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + linkJsLibOpts = + mempty + { ghcOptExtra = + [ "-link-js-lib" + , getHSLibraryName uid + , "-js-lib-outputdir" + , u libTargetDir + ] + ++ map u jsSrcs + } + vanillaOptsNoJsLib = + baseOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR $ allLibModules lib clbi + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts + + profOpts = + adjustExts "p_hi" "p_o" vanillaOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , -- ghcOptHiSuffix = toFlag "p_hi", + -- ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = + adjustExts "dyn_hi" "dyn_o" vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , -- ghcOptHiSuffix = toFlag "dyn_hi", + -- ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + vanillaSharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "js_dyn_hi" + , ghcOptDynObjSuffix = toFlag "js_dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ + do + let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) + useDynToo = + dynamicTooSupported + && (forceVanillaLib || withVanillaLib lbi) + && (forceSharedLib || withSharedLib lbi) + && null (hcSharedOptions GHC libBi) + if not has_code + then vanilla + else + if useDynToo + then do + runGhcjsProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Flag dynDir, Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir) + _ -> return () + else + if isGhcjsDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcjsProg profOpts) + + -- Build any C++ sources separately. + {- + unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCxxOpts = if isGhcjsDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcjsProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcjsProg replOpts) + -} + -- build any C sources + -- TODO: Add support for S and CMM files. + {- + unless (not has_code || null (cSources libBi) || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcjsDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcjsProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] + -} + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + + -- link: + + when has_code . when False {- fixme nativeToo -} . unless forRepl $ do + info verbosity "Linking..." + let cSharedObjs = + map + ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension))) + (cSources libBi ++ cxxSources libBi) + compiler_id = compilerId (compiler lbi) + sharedLibFilePath = libTargetDir makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid) + staticLibFilePath = libTargetDir makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid) + + let stubObjs = [] + stubSharedObjs = [] + + {- + stubObjs <- catMaybes <$> sequenceA + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubProfObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubSharedObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + -} + hObjs <- + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + (coerceSymbolicPath libTargetDir) + objExtension + True + hSharedObjs <- + if withSharedLib lbi + then + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + (coerceSymbolicPath libTargetDir) + ("dyn_" ++ objExtension) + False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir ) . getSymbolicPath) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir ) . getSymbolicPath) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptInputFiles = toNubListR dynamicObjectFiles + , ghcOptOutputFile = toFlag sharedLibFilePath + , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + , -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. This only applies to GHC < 7.8 - see the + -- discussion in #1660. + {- + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, -} + ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths + } + ghcStaticLinkArgs = + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) + {- + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath staticObjectFiles + -} + {- + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciProfLibFilePath profObjectFiles + -} + whenSharedLib False $ + runGhcjsProg ghcSharedLinkArgs + + whenStaticLib False $ + runGhcjsProg ghcStaticLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity packageDBs + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb + runGHC verbosity ghcjsProg comp platform Nothing replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib + +replFLib + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplFLib replFlags + +-- | Build an executable with GHC. +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe + +replExe + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplExe replFlags + +-- | Building an executable, starting the REPL, and building foreign +-- libraries are all very similar and implemented in 'gbuild'. The +-- 'GBuildMode' distinguishes between the various kinds of operation. +data GBuildMode + = GBuildExe Executable + | GReplExe [String] Executable + | GBuildFLib ForeignLib + | GReplFLib [String] ForeignLib + +gbuildInfo :: GBuildMode -> BuildInfo +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib + +gbuildName :: GBuildMode -> String +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib + +gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib + +exeTargetName :: Platform -> Executable -> String +exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform + +-- | Target name for a foreign library (the actual file name) +-- +-- We do not use mkLibName and co here because the naming for foreign libraries +-- is slightly different (we don't use "_p" or compiler version suffices, and we +-- don't want the "lib" prefix on Windows). +-- +-- TODO: We do use `dllExtension` and co here, but really that's wrong: they +-- use the OS used to build cabal to determine which extension to use, rather +-- than the target OS (but this is wrong elsewhere in Cabal as well). +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + os = + let (Platform _ os') = hostPlatform lbi + in os' + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) + == (Linux, ForeignLibNativeShared) = + let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + os = + let (Platform _ os') = hostPlatform lbi + in os' + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + +gbuildIsRepl :: GBuildMode -> Bool +gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GReplExe _ _) = True +gbuildIsRepl (GBuildFLib _) = False +gbuildIsRepl (GReplFLib _ _) = True + +gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool +gbuildNeedDynamic lbi bm = + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib + where + withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +gbuildModDefFiles :: GBuildMode -> [RelativePath Source File] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib +gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib + +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. +exeMainModuleName :: Executable -> Maybe ModuleName +exeMainModuleName Executable{buildInfo = bnfo} = + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest + findIsMainArgs (_ : rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | headOf main_fn isLower = + -- The arg looked like "Foo.Bar.baz" + Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = + Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = + Nothing + where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) + splitLongestPrefix str pred' + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + where + -- 'safeTail' drops the char satisfying 'pred' + (r_suf, r_pre) = break pred' (reverse str) + +-- | A collection of: +-- * C input files +-- * C++ input files +-- * GHC input files +-- * GHC input modules +-- +-- Used to correctly build and link sources. +data BuildSources = BuildSources + { cSourcesFiles :: [SymbolicPath Pkg File] + , cxxSourceFiles :: [SymbolicPath Pkg File] + , inputSourceFiles :: [SymbolicPath Pkg File] + , inputSourceModules :: [ModuleName] + } + +-- | Locate and return the 'BuildSources' required to build and link. +gbuildSources + :: Verbosity + -> Maybe (SymbolicPath CWD ('Dir Pkg)) + -> PackageId + -> CabalSpecVersion + -> SymbolicPath Pkg (Dir Source) + -> GBuildMode + -> IO BuildSources +gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib + where + exeSources :: Executable -> IO BuildSources + exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do + main <- findFileCwd verbosity mbWorkDir (tmpDir : hsSourceDirs bnfo) modPath + let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + otherModNames = exeModules exe + haskellMain = isHaskell (getSymbolicPath main) + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if haskellMain || pkgId == fakePackageId + then + if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = filter (/= mainModName) $ exeModules exe + } + else + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = exeModules exe + } + else + let (csf, cxxsf) + | isCxx (getSymbolicPath main) = (cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + in return + BuildSources + { cSourcesFiles = csf + , cxxSourceFiles = cxxsf + , inputSourceFiles = [] + , inputSourceModules = exeModules exe + } + + flibSources :: ForeignLib -> BuildSources + flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [] + , inputSourceModules = foreignLibModules flib + } + + isCxx :: FilePath -> Bool + isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] + +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] + +-- | Generic build function. See comment for 'GBuildMode'. +gbuild + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> GBuildMode + -> ComponentLocalBuildInfo + -> IO () +gbuild verbosity numJobs pkg_descr lbi bm clbi = do + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let replFlags = case bm of + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + mbWorkDir = mbWorkDirLBI lbi + runGhcProg = runGHC verbosity ghcjsProg comp platform mbWorkDir + + let (bnfo, threaded) = case bm of + GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) + _ -> (gbuildInfo bm, False) + + -- the name that GHC really uses (e.g., with .exe on Windows for executables) + let targetName = gbuildTargetName lbi bm + targetDir = buildDir lbi makeRelativePathEx (gbuildName bm) + tmpDir = targetDir makeRelativePathEx (gbuildName bm ++ "-tmp") + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPath mbWorkDir + + createDirectoryIfMissingVerbose verbosity True $ i targetDir + createDirectoryIfMissingVerbose verbosity True $ i tmpDir + + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = exeCoverage lbi + hpcdir way + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir coerceSymbolicPath extraCompilationArtifacts) way + | otherwise = mempty + + rpaths <- getRPaths lbi clbi + buildSources <- gbuildSources verbosity mbWorkDir (package pkg_descr) (specVersion pkg_descr) tmpDir bm + + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs + cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi + + -- build executables + buildRunner = case clbi of + LibComponentLocalBuildInfo{} -> False + FLibComponentLocalBuildInfo{} -> False + ExeComponentLocalBuildInfo{} -> True + TestComponentLocalBuildInfo{} -> True + BenchComponentLocalBuildInfo{} -> True + baseOpts = + (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptInputFiles = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (isHaskell . getSymbolicPath) inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (not . isHaskell . getSymbolicPath) inputFiles + else [] + , ghcOptInputModules = toNubListR inputModules + , -- for all executable components (exe/test/bench), + -- GHCJS must be passed the "-build-runner" option + ghcOptExtra = + if buildRunner + then ["-build-runner"] + else mempty + } + staticOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticOnly + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = + baseOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + False + (withProfExeDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcOptions GHC bnfo ++ hcSharedOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = + staticOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = PD.ldOptions bnfo + , ghcOptLinkLibs = extraLibs bnfo + , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo + , ghcOptLinkFrameworks = + toNubListR $ + map getSymbolicPath $ + PD.frameworks bnfo + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs bnfo + , ghcOptInputFiles = + toNubListR + [makeSymbolicPath $ getSymbolicPath tmpDir getSymbolicPath x | x <- cObjs ++ cxxObjs] + } + dynLinkerOpts = + mempty + { ghcOptRPaths = rpaths + } + replOpts = + baseOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replFlags + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts + | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts + | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = not needProfiling && not needDynamic + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = usesTemplateHaskellOrQQ bnfo + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = + dynamicTooSupported + && isGhcDynamic + && doingTH + && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts + | isGhcDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | gbuildIsRepl bm = False + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcProg + compileTHOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } + + -- Do not try to build anything if there are no input files. + -- This can happen if the cabal file ends up with only cSrcs + -- but no Haskell modules. + unless + ( (null inputFiles && null inputModules) + || gbuildIsRepl bm + ) + $ runGhcProg + compileOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } + + -- build any C++ sources + unless (null cxxSrcs) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do + let baseCxxOpts = + Internal.componentCxxGhcOptions + verbosity + lbi + bnfo + clbi + tmpDir + filename + vanillaCxxOpts = + if isGhcDynamic + then -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCxxOpts{ghcOptFPic = toFlag True} + else baseCxxOpts + profCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True (i odir) + needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs + ] + + -- build any C sources + unless (null cSrcs) $ do + info verbosity "Building C Sources..." + sequence_ + [ do + let baseCcOpts = + Internal.componentCcGhcOptions + verbosity + lbi + bnfo + clbi + tmpDir + filename + vanillaCcOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCcOpts{ghcOptFPic = toFlag True} + else baseCcOpts + profCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True (i odir) + needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs + ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + case bm of + GReplExe _ _ -> runGhcProg replOpts + GReplFLib _ _ -> runGhcProg replOpts + GBuildExe _ -> do + let linkOpts = + commonOpts + `mappend` linkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + + info verbosity "Linking..." + -- Work around old GHCs not relinking in this + -- situation, see #3294 + let target = targetDir makeRelativePathEx targetName + when (compilerVersion comp < mkVersion [7, 7]) $ do + let targetPath = i target + e <- doesFileExist targetPath + when e (removeFile targetPath) + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} + GBuildFLib flib -> do + let rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if needDynamic + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + linkOpts = case foreignLibType flib of + ForeignLibNativeShared -> + commonOpts + `mappend` linkerOpts + `mappend` dynLinkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ gbuildModDefFiles bm + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + info verbosity "Linking..." + let buildName = flibBuildName lbi flib + buildFile = targetDir makeRelativePathEx buildName + runGhcProg linkOpts{ghcOptOutputFile = toFlag buildFile} + renameFile (i buildFile) (i targetDir targetName) + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can +-- find this information somewhere. We can lookup the 'hsLibraries' field of +-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which +-- doesn't really help. +extractRtsInfo :: LocalBuildInfo -> RtsInfo +extractRtsInfo lbi = + case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" + where + aux :: InstalledPackageInfo -> RtsInfo + aux rts = + RtsInfo + { rtsDynamicInfo = + DynamicRtsInfo + { dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = + StaticRtsInfo + { statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } + withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) + +-- | Returns True if the modification date of the given source file is newer than +-- the object file we last compiled for it, or if no object file exists yet. +checkNeedsRecompilation + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg File + -> GhcOptions + -> IO Bool +checkNeedsRecompilation mbWorkDir filename opts = + i filename `moreRecentFile` oname + where + oname = getObjectFileName mbWorkDir filename opts + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + +-- | Finds the object file name of the given source file +getObjectFileName + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg File + -> GhcOptions + -> FilePath +getObjectFileName mbWorkDir filename opts = oname + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + odir = i $ fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + -- NB: the filepath might be absolute, e.g. if it is the path to + -- an autogenerated .hs file. + oname = odir replaceExtension (getSymbolicPath filename) oext + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths + :: LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + compid = compilerId . compiler $ lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = + case compid of + CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + _ -> False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = True + supportRPaths Haiku = False + supportRPaths (OtherOS _) = False +-- Do _not_ add a default case so that we get a warning here when a new OS +-- is added. + +getRPaths _ _ = return mempty + +-- | Remove the "-threaded" flag when building a foreign library, as it has no +-- effect when used with "-shared". Returns the updated 'BuildInfo', along +-- with whether or not the flag was present, so we can use it to link against +-- the appropriate RTS on our own. +popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) +popThreadedFlag bi = + ( bi{options = filterHcOptions (/= "-threaded") (options bi)} + , hasThreaded (options bi) + ) + where + filterHcOptions + :: (String -> Bool) + -> PerCompilerFlavor [String] + -> PerCompilerFlavor [String] + filterHcOptions p (PerCompilerFlavor ghc ghcjs) = + PerCompilerFlavor (filter p ghc) ghcjs + + hasThreaded :: PerCompilerFlavor [String] -> Bool + hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +libAbiHash + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + mbWorkDir = mbWorkDirLBI lbi + vanillaArgs = + (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "js_dyn_hi" + , ghcOptObjSuffix = toFlag "js_dyn_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "js_p_hi" + , ghcOptObjSuffix = toFlag "js_p_o" + , ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + hash <- + getProgramInvocationOutput + verbosity + =<< ghcInvocation verbosity ghcjsProg comp platform mbWorkDir ghcArgs + return (takeWhile (not . isSpace) hash) + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir build) + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir + in opts + { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi + } + +-- ----------------------------------------------------------------------------- +-- Installing + +-- | Install executables for GHCJS. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeName' + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + runDbProgramCwd verbosity (mbWorkDirLBI lbi) ghcjsProgram (withPrograms lbi) $ + [ "--install-executable" + , buildPref exeName' exeFileName + , "-o" + , dest + ] + ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of + (True, Just strip) -> ["-strip-program", programPath strip] + _ -> [] + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install _isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + installOrdinaryFile verbosity src dst + +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do + whenVanilla $ copyModuleFiles $ Suffix "js_hi" + whenProf $ copyModuleFiles $ Suffix "js_p_hi" + whenShared $ copyModuleFiles $ Suffix "js_dyn_hi" + + -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName + -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName + -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName + -- fixme do these make the correct lib names? + whenHasCode $ do + whenVanilla $ do + sequence_ + [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) + | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) + whenProf $ do + installOrdinary builtDir' targetDir (toJSLibName profileLibName) + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) + whenShared $ + sequence_ + [ installShared + builtDir' + dynlibTargetDir + (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + where + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + builtDir' = componentBuildDir lbi clbi + mbWorkDir = mbWorkDirLBI lbi + + install isShared isJS srcDir dstDir name = do + let src = i $ srcDir makeRelativePathEx name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi && not isJS) $ + Strip.stripLib + verbosity + (hostPlatform lbi) + (withPrograms lbi) + dst + + installOrdinary = install False True + installShared = install True True + + copyModuleFiles ext = do + files <- findModuleFilesCwd verbosity mbWorkDir [builtDir'] [ext] (allLibModules lib clbi) + let files' = map (i *** getSymbolicPath) files + installOrdinaryFiles verbosity targetDir files' + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + -- vanillaLibName = mkLibName uid + profileLibName = mkProfLibName uid + -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid + + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (jsSources (libBuildInfo lib)) + has_code = not (componentIsIndefinite clbi) + whenHasCode = when has_code + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi && has_code) + -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) + +adjustExts :: String -> String -> GhcOptions -> GhcOptions +adjustExts hiSuf objSuf opts = + opts + `mappend` mempty + { ghcOptHiSuffix = toFlag hiSuf + , ghcOptObjSuffix = toFlag objSuf + } + +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +withExt :: FilePath -> String -> FilePath +withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" + +findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsGhcVersion verbosity pgm = + findProgramVersion "--numeric-ghc-version" id verbosity pgm + +findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsPkgGhcjsVersion verbosity pgm = + findProgramVersion "--numeric-ghcjs-version" id verbosity pgm + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo progdb = + HcPkg.HcPkgInfo + { HcPkg.hcPkgProgram = ghcjsPkgProg + , HcPkg.noPkgDbStack = False + , HcPkg.noVerboseFlag = False + , HcPkg.flagPackageConf = False + , HcPkg.supportsDirDbs = True + , HcPkg.requiresDirDbs = ver >= v7_10 + , HcPkg.nativeMultiInstance = ver >= v7_10 + , HcPkg.recacheMultiInstance = True + , HcPkg.suppressFilesCheck = True + } + where + v7_10 = mkVersion [7, 10] + ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb + ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg + +registerPackage + :: Verbosity + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions = + HcPkg.register + (hcPkgInfo progdb) + verbosity + mbWorkDir + packageDbs + installedPkgInfo + registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath +pkgRoot verbosity lbi = pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) + pkgRoot' UserPackageDB = do + appDir <- getAppUserDataDirectory "ghcjs" + -- fixme correct this version + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exists. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = + return $ + takeDirectory $ + interpretSymbolicPathLBI lbi fp + +-- | Get the JavaScript file name and command and arguments to run a +-- program compiled by GHCJS +-- the exe should be the base program name without exe extension +runCmd + :: ProgramDb + -> FilePath + -> (FilePath, FilePath, [String]) +runCmd progdb exe = + ( script + , programPath ghcjsProg + , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] + ) + where + script = exe <.> "jsexe" "all" <.> "js" + ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb diff --git a/src/Distribution/Simple/Glob.hs b/src/Distribution/Simple/Glob.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Glob.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Glob +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple file globbing. +module Distribution.Simple.Glob + ( -- * Globs + Glob + + -- * Matching on globs + , GlobResult (..) + , globMatches + , fileGlobMatches + , matchGlob + , matchGlobPieces + , matchDirFileGlob + , matchDirFileGlobWithDie + , runDirFileGlob + + -- * Parsing globs + , parseFileGlob + , GlobSyntaxError (..) + , explainGlobSyntaxError + + -- * Utility + , isRecursiveInRoot + ) +where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion + ( CabalSpecVersion (..) + ) +import Distribution.Pretty +import Distribution.Simple.Errors + ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors) + ) +import Distribution.Simple.Glob.Internal +import Distribution.Simple.Utils + ( debug + , dieWithException + , getDirectoryContentsRecursive + , warn + ) +import Distribution.Utils.Path +import Distribution.Verbosity + ( Verbosity + , silent + ) + +import Control.Monad (mapM) +import Data.List (stripPrefix) +import System.Directory +import System.FilePath hiding ((<.>), ()) + +------------------------------------------------------------------------------- + +-- * Matching + +-------------------------------------------------------------------------------- + +-- | Match a 'Glob' against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +-- @since 3.12.0.0 +matchGlob :: FilePath -> Glob -> IO [FilePath] +matchGlob root glob = + -- For this function, which is the general globbing one (doesn't care about + -- cabal spec, used e.g. for monitoring), we consider all matches. + mapMaybe + ( \case + GlobMatch a -> Just a + GlobWarnMultiDot a -> Just a + GlobMatchesDirectory a -> Just a + GlobMissingDirectory{} -> Nothing + ) + <$> runDirFileGlob silent Nothing root glob + +-- | Match a globbing pattern against a file path component +matchGlobPieces :: GlobPieces -> String -> Bool +matchGlobPieces = goStart + where + -- From the man page, glob(7): + -- "If a filename starts with a '.', this character must be + -- matched explicitly." + + go, goStart :: [GlobPiece] -> String -> Bool + + goStart (WildCard : _) ('.' : _) = False + goStart (Union globs : rest) cs = + any + (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit : rest) cs + | Just cs' <- stripPrefix lit cs = + go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs + go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_ : _) = False + go (_ : _) "" = False + +-- | Extract the matches from a list of 'GlobResult's. +-- +-- Note: throws away the 'GlobMissingDirectory' results; chances are +-- that you want to check for these and error out if any are present. +-- +-- @since 3.12.0.0 +globMatches :: [GlobResult a] -> [a] +globMatches input = [a | GlobMatch a <- input] + +-- | This will 'die'' when the glob matches no files, or if the glob +-- refers to a missing directory, or if the glob fails to parse. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The first 'FilePath' argument is the directory that the glob is +-- relative to. It must be a valid directory (and hence it can't be +-- the empty string). The returned values will not include this +-- prefix. +-- +-- The second 'FilePath' is the glob itself. +matchDirFileGlob + :: Verbosity + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir dir)) + -> SymbolicPathX allowAbs dir file + -> IO [SymbolicPathX allowAbs dir file] +matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException + +-- | Like 'matchDirFileGlob' but with customizable 'die' +-- +-- @since 3.6.0.0 +matchDirFileGlobWithDie + :: Verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir dir)) + -> SymbolicPathX allowAbs dir file + -> IO [SymbolicPathX allowAbs dir file] +matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath = + let rawFilePath = getSymbolicPath symPath + dir = maybe "." getSymbolicPath mbWorkDir + in case parseFileGlob version rawFilePath of + Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError rawFilePath err) + Right glob -> do + results <- runDirFileGlob verbosity (Just version) dir glob + let missingDirectories = + [missingDir | GlobMissingDirectory missingDir <- results] + matches = globMatches results + directoryMatches = [a | GlobMatchesDirectory a <- results] + + let errors :: [String] + errors = + [ "filepath wildcard '" + ++ rawFilePath + ++ "' refers to the directory" + ++ " '" + ++ missingDir + ++ "', which does not exist or is not a directory." + | missingDir <- missingDirectories + ] + ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files." + | null matches && null directoryMatches + -- we don't error out on directory matches, simply warn about them and ignore. + ] + + warns :: [String] + warns = + [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)." + | path <- directoryMatches + ] + + if null errors + then do + unless (null warns) $ + warn verbosity $ + unlines warns + return $ map unsafeMakeSymbolicPath matches + else rip verbosity $ MatchDirFileGlobErrors errors + +------------------------------------------------------------------------------- + +-- * Parsing & printing + +-------------------------------------------------------------------------------- +-- Filepaths with globs may be parsed in the special context is globbing in +-- cabal package fields, such as `data-files`. In that case, we restrict the +-- globbing syntax to that supported by the cabal spec version in use. +-- Otherwise, we parse the globs to the extent of our globbing features +-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). + +-- ** Parsing globs in a cabal package + +parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob +parseFileGlob version filepath = case reverse (splitDirectories filepath) of + [] -> + Left EmptyGlob + (filename : "**" : segments) + | allowGlobStar -> do + finalSegment <- case splitExtensions filename of + ("*", ext) + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext]) + _ + | allowLiteralFilenameGlobStar -> + Right (GlobDirRecursive [Literal filename]) + | otherwise -> + Left LiteralFileNameGlobStar + + foldM addStem finalSegment segments + | otherwise -> Left VersionDoesNotSupportGlobStar + (filename : segments) -> do + pat <- case splitExtensions filename of + ("*", ext) + | not allowGlob -> Left VersionDoesNotSupportGlob + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobFile [WildCard, Literal ext]) + (_, ext) + | '*' `elem` ext -> Left StarInExtension + | '*' `elem` filename -> Left StarInFileName + | otherwise -> Right (GlobFile [Literal filename]) + + foldM addStem pat segments + where + addStem pat seg + | '*' `elem` seg = Left StarInDirectory + | otherwise = Right (GlobDir [Literal seg] pat) + allowGlob = version >= CabalSpecV1_6 + allowGlobStar = version >= CabalSpecV2_4 + allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 + +enableMultidot :: CabalSpecVersion -> Bool +enableMultidot version + | version >= CabalSpecV2_4 = True + | otherwise = False + +-------------------------------------------------------------------------------- +-- Parse and printing utils +-------------------------------------------------------------------------------- + +-- ** Cabal package globbing errors + +data GlobSyntaxError + = StarInDirectory + | StarInFileName + | StarInExtension + | NoExtensionOnStar + | EmptyGlob + | LiteralFileNameGlobStar + | VersionDoesNotSupportGlobStar + | VersionDoesNotSupportGlob + deriving (Eq, Show) + +explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String +explainGlobSyntaxError filepath StarInDirectory = + "invalid file glob '" + ++ filepath + ++ "'. A wildcard '**' is only allowed as the final parent" + ++ " directory. Stars must not otherwise appear in the parent" + ++ " directories." +explainGlobSyntaxError filepath StarInExtension = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' are only allowed as the" + ++ " file's base name, not in the file extension." +explainGlobSyntaxError filepath StarInFileName = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' may only totally replace the" + ++ " file's base name, not only parts of it." +explainGlobSyntaxError filepath NoExtensionOnStar = + "invalid file glob '" + ++ filepath + ++ "'. If a wildcard '*' is used it must be with an file extension." +explainGlobSyntaxError filepath LiteralFileNameGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" + ++ " file's base name must be a wildcard '*'." +explainGlobSyntaxError _ EmptyGlob = + "invalid file glob. A glob cannot be the empty string." +explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" + ++ " or greater. Alternatively, for compatibility with earlier Cabal" + ++ " versions, list the included directories explicitly." +explainGlobSyntaxError filepath VersionDoesNotSupportGlob = + "invalid file glob '" + ++ filepath + ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." + +-- Note throughout that we use splitDirectories, not splitPath. On +-- Posix, this makes no difference, but, because Windows accepts both +-- slash and backslash as its path separators, if we left in the +-- separators from the glob we might not end up properly normalised. + +data GlobResult a + = -- | The glob matched the value supplied. + GlobMatch a + | -- | The glob did not match the value supplied because the + -- cabal-version is too low and the extensions on the file did + -- not precisely match the glob's extensions, but rather the + -- glob was a proper suffix of the file's extensions; i.e., if + -- not for the low cabal-version, it would have matched. + GlobWarnMultiDot a + | -- | The glob couldn't match because the directory named doesn't + -- exist. The directory will be as it appears in the glob (i.e., + -- relative to the directory passed to 'matchDirFileGlob', and, + -- for 'data-files', relative to 'data-dir'). + GlobMissingDirectory a + | -- | The glob matched a directory when we were looking for files only. + -- It didn't match a file! + -- + -- @since 3.12.0.0 + GlobMatchesDirectory a + deriving (Show, Eq, Ord, Functor) + +-- | Match files against a pre-parsed glob, starting in a directory. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The 'FilePath' argument is the directory that the glob is relative +-- to. It must be a valid directory (and hence it can't be the empty +-- string). The returned values will not include this prefix. +runDirFileGlob + :: Verbosity + -> Maybe CabalSpecVersion + -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version. + -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! + -> FilePath + -> Glob + -> IO [GlobResult FilePath] +runDirFileGlob verbosity mspec rawRoot pat = do + -- The default data-dir is null. Our callers -should- be + -- converting that to '.' themselves, but it's a certainty that + -- some future call-site will forget and trigger a really + -- hard-to-debug failure if we don't check for that here. + when (null rawRoot) $ + warn verbosity $ + "Null dir passed to runDirFileGlob; interpreting it " + ++ "as '.'. This is probably an internal error." + let root = if null rawRoot then "." else rawRoot + -- This function might be called from the project root with dir as + -- ".". Walking the tree starting there involves going into .git/ + -- and dist-newstyle/, which is a lot of work for no reward, so + -- extract the constant prefix from the pattern and start walking + -- there, and only walk as much as we need to: recursively if **, + -- the whole directory if *, and just the specific file if it's a + -- literal. + let + (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat + joinedPrefix = joinPath prefixSegments + + -- The glob matching function depends on whether we care about the cabal version or not + doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ()) + doesGlobMatch glob str = case mspec of + Just spec -> checkNameMatches spec glob str + Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing + + go (GlobFile glob) dir = do + entries <- getDirectoryContents (root dir) + catMaybes + <$> mapM + ( \s -> do + -- When running a glob from a Cabal package description (i.e. + -- when a cabal spec version is passed as an argument), we + -- disallow matching a @GlobFile@ against a directory, preferring + -- @GlobDir dir GlobDirTrailing@ to specify a directory match. + isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec + let match = (dir s <$) <$> doesGlobMatch glob s + return $ + if isFile + then match + else case match of + Just (GlobMatch x) -> Just $ GlobMatchesDirectory x + Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x + Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x + Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess + Nothing -> Nothing + ) + entries + go (GlobDirRecursive glob) dir = do + entries <- getDirectoryContentsRecursive (root dir) + return $ + mapMaybe + ( \s -> do + globMatch <- doesGlobMatch glob (takeFileName s) + pure ((dir s) <$ globMatch) + ) + entries + go (GlobDir glob globPath) dir = do + entries <- getDirectoryContents (root dir) + subdirs <- + filterM + ( \subdir -> + doesDirectoryExist + (root dir subdir) + ) + $ filter (matchGlobPieces glob) entries + concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs + go GlobDirTrailing dir = return [GlobMatch dir] + + case pathOrVariablePattern of + Left filename -> do + let filepath = joinedPrefix filename + debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root filepath) + if directoryExists + then pure [GlobMatchesDirectory filepath] + else do + exist <- doesFileExist (root filepath) + pure $ + if exist + then [GlobMatch filepath] + else [] + Right variablePattern -> do + debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root joinedPrefix) + if directoryExists + then go variablePattern joinedPrefix + else return [GlobMissingDirectory joinedPrefix] + where + -- \| Extract the (possibly null) constant prefix from the pattern. + -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, + -- then @pat === foldr GlobDir final pref@. + splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob) + splitConstantPrefix = fmap literalize . unfoldr' step + where + literalize (GlobFile [Literal filename]) = + Left filename + literalize glob = + Right glob + + step (GlobDir [Literal seg] pat') = Right (seg, pat') + step pat' = Left pat' + + unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) + unfoldr' f a = case f a of + Left r -> ([], r) + Right (b, a') -> case unfoldr' f a' of + (bs, r) -> (b : bs, r) + +-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ? +isRecursiveInRoot :: Glob -> Bool +isRecursiveInRoot (GlobDirRecursive _) = True +isRecursiveInRoot _ = False + +-- | Check how the string matches the glob under this cabal version +checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ()) +checkNameMatches spec glob candidate + -- Check if glob matches in its general form + | matchGlobPieces glob candidate = + -- if multidot is supported, then this is a clean match + if enableMultidot spec + then pure (GlobMatch ()) + else -- if not, issue a warning saying multidot is needed for the match + + let (_, candidateExts) = splitExtensions $ takeFileName candidate + extractExts :: GlobPieces -> Maybe String + extractExts [] = Nothing + extractExts [Literal lit] + -- Any literal terminating a glob, and which does have an extension, + -- returns that extension. Otherwise, recurse until Nothing is returned. + | let ext = takeExtensions lit + , ext /= "" = + Just ext + extractExts (_ : x) = extractExts x + in case extractExts glob of + Just exts + | exts == candidateExts -> + return (GlobMatch ()) + | exts `isSuffixOf` candidateExts -> + return (GlobWarnMultiDot ()) + _ -> return (GlobMatch ()) + | otherwise = empty + +-- | How/does the glob match the given filepath, according to the cabal version? +-- Since this is pure, we don't make a distinction between matching on +-- directories or files (i.e. this function won't return 'GlobMatchesDirectory') +fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ()) +fileGlobMatches version g path = go g (splitDirectories path) + where + go GlobDirTrailing [] = Just (GlobMatch ()) + go (GlobFile glob) [file] = checkNameMatches version glob file + go (GlobDirRecursive glob) dirs + | [] <- reverse dirs = + Nothing -- @dir/**/x.txt@ should not match @dir/hello@ + | file : _ <- reverse dirs = + checkNameMatches version glob file + go (GlobDir glob globPath) (dir : dirs) = do + _ <- checkNameMatches version glob dir -- we only care if dir segment matches + go globPath dirs + go _ _ = Nothing 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Haddock.hs @@ -0,0 +1,1634 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. +-- It uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating HTML versions of the original +-- source, with coloured syntax highlighting. +module Distribution.Simple.Haddock + ( haddock + , haddock_setupHooks + , createHaddockIndex + , hscolour + , hscolour_setupHooks + , haddockPackagePaths + , Visibility (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +-- local + +import Distribution.Backpack (OpenModule) +import Distribution.Backpack.DescribeUnitId +import Distribution.Compat.Semigroup (All (..), Any (..)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty +import Distribution.Simple.Build +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.InstallDirs +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Register +import Distribution.Simple.Setup +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExposedModule +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Utils.Path hiding + ( Dir + ) +import qualified Distribution.Utils.Path as Path +import qualified Distribution.Utils.ShortText as ShortText +import Distribution.Verbosity +import Distribution.Version + +import Control.Monad +import Data.Bool (bool) +import Data.Either (rights) +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (isAbsolute, normalise) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) + +-- ------------------------------------------------------------------------------ +-- Types + +-- | A record that represents the arguments to the haddock executable, a product +-- monoid. +data HaddockArgs = HaddockArgs + { argInterfaceFile :: Flag FilePath + -- ^ Path to the interface file, relative to argOutputDir, required. + , argPackageName :: Flag PackageIdentifier + -- ^ Package name, required. + , argComponentName :: Flag String + -- ^ Optional name used to construct haddock's `--package-name` option for + -- various components (tests suites, sublibriaries, etc). + , argHideModules :: (All, [ModuleName.ModuleName]) + -- ^ (Hide modules ?, modules to hide) + , argIgnoreExports :: Any + -- ^ Ignore export lists in modules? + , argLinkSource :: Flag (Template, Template, Template) + -- ^ (Template for modules, template for symbols, template for lines). + , argLinkedSource :: Flag Bool + -- ^ Generate hyperlinked sources + , argQuickJump :: Flag Bool + -- ^ Generate quickjump index + , argCssFile :: Flag FilePath + -- ^ Optional custom CSS file. + , argContents :: Flag String + -- ^ Optional URL to contents page. + , argGenContents :: Flag Bool + -- ^ Generate contents + , argIndex :: Flag String + -- ^ Optional URL to index page. + , argGenIndex :: Flag Bool + -- ^ Generate index + , argBaseUrl :: Flag String + -- ^ Optional base url from which static files will be loaded. + , argVerbose :: Any + , argOutput :: Flag [Output] + -- ^ HTML or Hoogle doc or both? Required. + , argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)] + -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. + , argOutputDir :: Directory + -- ^ Where to generate the documentation. + , argTitle :: Flag String + -- ^ Page title, required. + , argPrologue :: Flag String + -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'. + , argPrologueFile :: Flag FilePath + -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'. + , argGhcOptions :: GhcOptions + -- ^ Additional flags to pass to GHC. + , argGhcLibDir :: Flag FilePath + -- ^ To find the correct GHC, required. + , argReexports :: [OpenModule] + -- ^ Re-exported modules + , argTargets :: [FilePath] + -- ^ Modules to process. + , argResourcesDir :: Flag String + -- ^ haddock's static \/ auxiliary files. + , argUseUnicode :: Flag Bool + -- ^ haddock's `--use-unicode` flag + } + deriving (Generic) + +-- | The FilePath of a directory, it's a monoid under '()'. +newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord) + +-- NB: only correct at the top-level, after we have combined monoidally +-- the top-level output directory with the component subdir. +unDir :: Directory -> SymbolicPath Pkg (Path.Dir Artifacts) +unDir = makeSymbolicPath . normalise . unDir' + +type Template = String + +data Output = Html | Hoogle + deriving (Eq) + +-- ------------------------------------------------------------------------------ +-- Haddock support + +-- | Get Haddock program and check if it matches the request +getHaddockProg + :: Verbosity + -> ProgramDb + -> Compiler + -> HaddockArgs + -> Flag Bool + -- ^ quickjump feature + -> IO (ConfiguredProgram, Version) +getHaddockProg verbosity programDb comp args quickJumpFlag = do + let HaddockArgs + { argQuickJump + , argOutput + } = args + hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput + + (haddockProg, version, _) <- + requireProgramVersion + verbosity + haddockProgram + (orLaterVersion (mkVersion [2, 0])) + programDb + + -- various sanity checks + when (hoogle && version < mkVersion [2, 2]) $ + dieWithException verbosity NoSupportForHoogle + + when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do + let msg = "Haddock prior to 2.19 does not support the --quickjump flag." + alt = "The generated documentation won't have the QuickJump feature." + if Flag True == quickJumpFlag + then dieWithException verbosity NoSupportForQuickJumpFlag + else warn verbosity (msg ++ "\n" ++ alt) + + haddockGhcVersionStr <- + getProgramOutput + verbosity + haddockProg + ["--ghc-version"] + case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of + (Nothing, _) -> dieWithException verbosity NoGHCVersionFromHaddock + (_, Nothing) -> dieWithException verbosity NoGHCVersionFromCompiler + (Just haddockGhcVersion, Just ghcVersion) + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> dieWithException verbosity $ HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion + + return (haddockProg, version) + +haddock + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock = haddock_setupHooks noBuildHooks + +haddock_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock_setupHooks + _ + pkg_descr + _ + _ + haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) = + warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests," + ++ " --benchmarks or --foreign-libraries flags." +haddock_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + suffixes + flags' = do + let verbosity = fromFlag $ haddockVerbosity flags + mbWorkDir = flagToMaybe $ haddockWorkingDir flags + comp = compiler lbi + platform = hostPlatform lbi + config = configFlags lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> + flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockLinkedSource = Flag True + , haddockQuickJump = Flag True + } + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = + commonSetupTempFileOptions $ configCommonFlags config + htmlTemplate = + fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ + flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + libdirArgs <- getGhcLibDir verbosity lbi + -- The haddock-output-dir flag overrides any other documentation placement concerns. + -- The point is to give the user full freedom over the location if they need it. + let overrideWithOutputDir args = case haddockOutputDir flags of + NoFlag -> args + Flag dir -> args{argOutputDir = Dir dir} + let commonArgs = + overrideWithOutputDir $ + mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription haddockTarget pkg_descr + ] + + (haddockProg, version) <- + getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] + when using_hscolour $ + hscolour' + noBuildHooks + -- NB: we are not passing the user BuildHooks here, + -- because we are already running the pre/post build hooks + -- for Haddock. + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) + + targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) + + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets + + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) + + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + curDir <- absoluteWorkingDirLBI lbi + let + component = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo component + -- Include any build-tool-depends on build tools internal to the current package. + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHaddock flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + + -- See Note [Hi Haddock Recompilation Avoidance] + reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do + preBuildComponent runPreBuildHooks verbosity lbi' target + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + exeArgs <- + fromExecutable + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + exe + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + exeArgs + Nothing -> do + warn + verbosity + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = + setupMessage' + verbosity + "Running Haddock on" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + ipi <- case component of + CLib lib -> do + smsg + libArgs <- + fromLibrary + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + lib + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + libArgs + inplaceDir <- absoluteWorkingDirLBI lbi + + let + ipi = + inplaceInstalledPackageInfo + inplaceDir + (flag $ setupDistPref . haddockCommonFlags) + pkg_descr + (mkAbiHash "inplace") + lib + lbi' + clbi + + debug verbosity $ + "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + + registerPackage + verbosity + (compiler lbi') + (withPrograms lbi') + mbWorkDir + (withPackageDB lbi') + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + + return $ PackageIndex.insert ipi index + CFLib flib -> + when + (flag haddockForeignLibs) + ( do + smsg + flibArgs <- + fromForeignLib + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + flib + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + flibArgs + ) + >> return index + CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index + CTest test -> do + when (flag haddockTestSuites) $ do + smsg + testArgs <- + fromTest + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + test + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + testArgs + return index + CBench bench -> do + when (flag haddockBenchmarks) $ do + smsg + benchArgs <- + fromBenchmark + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + bench + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + benchArgs + return index + + return ipi + + for_ (extraDocFiles pkg_descr) $ \fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath + let targetDir = Dir $ unDir' (argOutputDir commonArgs) haddockDirName haddockTarget pkg_descr + for_ files $ + copyFileToCwd verbosity mbWorkDir (unDir targetDir) + +-- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build +-- index and contents for documentation of multiple packages. +createHaddockIndex + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -> HaddockProjectFlags + -> IO () +createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do + let args = fromHaddockProjectFlags flags + tmpFileOpts = + commonSetupTempFileOptions $ haddockProjectCommonFlags $ flags + (haddockProg, _version) <- + getHaddockProg verbosity programDb comp args (Flag True) + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args + +-- ------------------------------------------------------------------------------ +-- Contributions to HaddockArgs (see also Doctest.hs for very similar code). + +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env flags = + mempty + { argHideModules = + ( maybe mempty (All . not) $ + flagToMaybe (haddockInternal flags) + , mempty + ) + , argLinkSource = + if fromFlag (haddockLinkedSource flags) + then + Flag + ( "src/%{MODULE/./-}.html" + , "src/%{MODULE/./-}.html#%{NAME}" + , "src/%{MODULE/./-}.html#line-%{LINE}" + ) + else NoFlag + , argLinkedSource = haddockLinkedSource flags + , argQuickJump = haddockQuickJump flags + , argCssFile = haddockCss flags + , argContents = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockContents flags) + , argGenContents = Flag False + , argIndex = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockIndex flags) + , argGenIndex = Flag False + , argBaseUrl = haddockBaseUrl flags + , argResourcesDir = haddockResourcesDir flags + , argVerbose = + maybe mempty (Any . (>= deafening)) + . flagToMaybe + $ setupVerbosity commonFlags + , argOutput = + Flag $ case [Html | Flag True <- [haddockHtml flags]] + ++ [Hoogle | Flag True <- [haddockHoogle flags]] of + [] -> [Html] + os -> os + , argOutputDir = maybe mempty (Dir . getSymbolicPath) . flagToMaybe $ setupDistPref commonFlags + , argGhcOptions = mempty{ghcOptExtra = ghcArgs} + , argUseUnicode = haddockUseUnicode flags + } + where + ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags + commonFlags = haddockCommonFlags flags + +fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs +fromHaddockProjectFlags flags = + mempty + { argOutputDir = Dir (fromFlag $ haddockProjectDir flags) + , argQuickJump = Flag True + , argGenContents = Flag True + , argGenIndex = Flag True + , argPrologueFile = haddockProjectPrologue flags + , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) + , argLinkedSource = Flag True + , argResourcesDir = haddockProjectResourcesDir flags + , argCssFile = haddockProjectCss flags + } + +fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs +fromPackageDescription _haddockTarget pkg_descr = + mempty + { argInterfaceFile = Flag $ haddockPath pkg_descr + , argPackageName = Flag $ packageId $ pkg_descr + , argOutputDir = Dir $ "doc" "html" + , argPrologue = + Flag $ + ShortText.fromShortText $ + if ShortText.null desc + then synopsis pkg_descr + else desc + , argTitle = Flag $ showPkg ++ subtitle + } + where + desc = description pkg_descr + showPkg = prettyShow (packageId pkg_descr) + subtitle + | ShortText.null (synopsis pkg_descr) = "" + | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Path.Dir build) + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let f = case compilerFlavor (compiler lbi) of + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> + error $ + "Distribution.Simple.Haddock.componentGhcOptions:" + ++ "haddock only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +{- +Note [Hi Haddock Recompilation Avoidance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Starting with Haddock 2.28, we no longer want to run Haddock's GHC session in +an arbitrary temporary directory. Doing so always causes recompilation during +documentation generation, which can now be avoided thanks to Hi Haddock. + +Instead, we want to re-use the interface and object files produced by GHC. +We copy these intermediate files produced by GHC to temporary directories and +point haddock to them. + +The reason why we can't use the GHC files /inplace/ is that haddock may have to +recompile (e.g. because of `haddock-options`). In that case, we want to be sure +the files produced by GHC do not get overwritten. + +See https://github.com/haskell/cabal/pull/9177 for discussion. + +(W.1) As it turns out, -stubdir is included in GHC's recompilation fingerprint. +This means that if we use a temporary directory for stubfiles produced by GHC +for the haddock invocation, haddock will trigger full recompilation since the +stubdir would be different. + +So we don't use a temporary stubdir, despite the tmp o-dir and hi-dir: + +We want to avoid at all costs haddock accidentally overwriting o-files and +hi-files (e.g. if a user specified haddock-option triggers recompilation), and +thus copy them to a temporary directory to pass them on to haddock. However, +stub files are much less problematic since ABI-incompatibility isn't at play +here, that is, there doesn't seem to be a GHC flag that could accidentally make +a stub file incompatible with the one produced by GHC from the same module. +-} + +mkHaddockArgs + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> [SymbolicPath Pkg File] + -> BuildInfo + -> IO HaddockArgs +mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do + let + vanillaOpts' = + componentGhcOptions normal lbi bi clbi (buildDir lbi) + vanillaOpts = + vanillaOpts' + { -- See Note [Hi Haddock Recompilation Avoidance] + ghcOptObjDir = toFlag tmpObjDir + , ghcOptHiDir = toFlag tmpHiDir + , ghcOptStubDir = toFlag tmpStubDir + } + sharedOpts = + vanillaOpts + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bi + } + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + opts <- + if withVanillaLib lbi + then return vanillaOpts + else + if withSharedLib lbi + then return sharedOpts + else dieWithException verbosity MustHaveSharedLibraries + + return + ifaceArgs + { argGhcOptions = opts + , argTargets = map getSymbolicPath inFiles + , argReexports = getReexports clbi + } + +fromLibrary + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> Library + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromLibrary verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr lib commonArgs = do + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (libBuildInfo lib) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ haddockLibraryDirPath haddockTarget pkg_descr lib + , argInterfaceFile = Flag $ haddockLibraryPath pkg_descr lib + } + args'' = + args' + { argHideModules = (mempty, otherModules (libBuildInfo lib)) + , argTitle = Flag $ haddockPackageLibraryName pkg_descr lib + , argComponentName = toFlag (haddockPackageLibraryName' (pkgName (package pkg_descr)) (libName lib)) + , -- we need to accommodate for `argOutputDir`, see `haddockLibraryPath` + argBaseUrl = case (libName lib, argBaseUrl args') of + (LSubLibName _, Flag url) -> Flag $ ".." url + (_, a) -> a + , argContents = case (libName lib, argContents args') of + (LSubLibName _, Flag url) -> Flag $ ".." url + (_, a) -> a + , argIndex = case (libName lib, argIndex args') of + (LSubLibName _, Flag url) -> Flag $ ".." url + (_, a) -> a + } + return args'' + +fromExecutable + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> Executable + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromExecutable verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr exe commonArgs = do + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (buildInfo exe) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (exeName exe) + } + return + args' + { argTitle = Flag $ unUnqualComponentName $ exeName exe + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +fromTest + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> TestSuite + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromTest verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr test commonArgs = do + inFiles <- map snd `fmap` getTestSourceFiles verbosity lbi test clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (testBuildInfo test) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (testName test) + } + return + args' + { argTitle = Flag $ prettyShow (packageName pkg_descr) + , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (testName test) + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +fromBenchmark + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> Benchmark + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromBenchmark verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr bench commonArgs = do + inFiles <- map snd `fmap` getBenchmarkSourceFiles verbosity lbi bench clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (benchmarkBuildInfo bench) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (benchmarkName bench) + } + return + args' + { argTitle = Flag $ prettyShow (packageName pkg_descr) + , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (benchmarkName bench) + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +fromForeignLib + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> ForeignLib + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromForeignLib verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr flib commonArgs = do + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (foreignLibBuildInfo flib) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (foreignLibName flib) + } + return + args' + { argTitle = Flag $ unUnqualComponentName $ foreignLibName flib + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +compToExe :: Component -> Maybe Executable +compToExe comp = + case comp of + CTest test@TestSuite{testInterface = TestSuiteExeV10 _ f} -> + Just + Executable + { exeName = testName test + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } + CBench bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ f} -> + Just + Executable + { exeName = benchmarkName bench + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bench + } + CExe exe -> Just exe + _ -> Nothing + +getInterfaces + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> IO HaddockArgs +getInterfaces verbosity lbi clbi htmlTemplate = do + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate + traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + return $ + mempty + { argInterfaces = packageFlags + } + +getReexports :: ComponentLocalBuildInfo -> [OpenModule] +getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} = + mapMaybe exposedReexport mods +getReexports _ = [] + +getGhcLibDir + :: Verbosity + -> LocalBuildInfo + -> IO HaddockArgs +getGhcLibDir verbosity lbi = do + l <- case compilerFlavor (compiler lbi) of + GHC -> GHC.getLibDir verbosity lbi + GHCJS -> GHCJS.getLibDir verbosity lbi + _ -> error "haddock only supports GHC and GHCJS" + return $ mempty{argGhcLibDir = Flag l} + +-- | If Hi Haddock is supported, this function creates temporary directories +-- and copies existing interface and object files produced by GHC into them, +-- then passes them off to the given continuation. +-- +-- If Hi Haddock is _not_ supported, we can't re-use GHC's compilation files. +-- Instead, we use a clean temporary directory to the continuation, +-- with no hope for recompilation avoidance. +-- +-- See Note [Hi Haddock Recompilation Avoidance] +reusingGHCCompilationArtifacts + :: Verbosity + -> TempFileOptions + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -- ^ Working directory + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> Version + -- ^ Haddock's version + -> ((SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) -> IO r) + -- ^ Continuation + -> IO r +reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act + | version >= mkVersion [2, 28, 0] = do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir -> + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do + -- Re-use ghc's interface and obj files, but first copy them to + -- somewhere where it is safe if haddock overwrites them + let + vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi) + i = interpretSymbolicPath mbWorkDir + copyDir getGhcDir tmpDir = do + let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts + ghcDirExists <- doesDirectoryExist ghcDir + -- Don't try to copy artifacts if they don't exist, e.g. if + -- we have not yet run the 'build' command. + when ghcDirExists $ + copyDirectoryRecursive verbosity ghcDir (i tmpDir) + copyDir ghcOptObjDir tmpObjDir + copyDir ghcOptHiDir tmpHiDir + -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance]) + + act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts) + | otherwise = do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ + \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback) + +-- ------------------------------------------------------------------------------ + +-- | Call haddock with the specified arguments. +runHaddock + :: Verbosity + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -> TempFileOptions + -> Compiler + -> Platform + -> ConfiguredProgram + -> Bool + -- ^ require targets + -> HaddockArgs + -> IO () +runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg requireTargets args + | requireTargets && null (argTargets args) = + warn verbosity $ + "Haddocks are being requested, but there aren't any modules given " + ++ "to create documentation for." + | otherwise = do + let haddockVersion = + fromMaybe + (error "unable to determine haddock version") + (programVersion haddockProg) + renderArgs verbosity mbWorkDir tmpFileOpts haddockVersion comp platform args $ + \flags result -> do + runProgramCwd verbosity mbWorkDir haddockProg flags + notice verbosity $ "Documentation created: " ++ result + +renderArgs + :: forall a + . Verbosity + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -> TempFileOptions + -> Version + -> Compiler + -> Platform + -> HaddockArgs + -> ([String] -> FilePath -> IO a) + -> IO a +renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do + let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4] + haddockSupportsResponseFiles = version > mkVersion [2, 16, 2] + createDirectoryIfMissingVerbose verbosity True (i outputDir) + let withPrologueArgs prologueArgs = + let renderedArgs = prologueArgs <> renderPureArgs version comp platform args + in if haddockSupportsResponseFiles + then + withResponseFile + verbosity + tmpFileOpts + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k ["@" ++ responseFileName] result) + else k renderedArgs result + case (argPrologueFile args, argPrologue args) of + (Flag pfile, _) -> + withPrologueArgs ["--prologue=" ++ pfile] + (_, Flag prologueText) -> + withTempFileEx tmpFileOpts "haddock-prologue.txt" $ + \prologueFileName h -> do + when haddockSupportsUTF8 (hSetEncoding h utf8) + hPutStrLn h prologueText + hClose h + withPrologueArgs ["--prologue=" ++ u prologueFileName] + (NoFlag, NoFlag) -> + withPrologueArgs [] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPath mbWorkDir + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + outputDir = coerceSymbolicPath $ unDir $ argOutputDir args + isNotArgContents = isNothing (flagToMaybe $ argContents args) + isNotArgIndex = isNothing (flagToMaybe $ argIndex args) + isArgGenIndex = fromFlagOrDefault False (argGenIndex args) + -- Haddock, when generating HTML, does not generate an index if the options + -- --use-contents or --use-index are passed to it. See + -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents + isIndexGenerated = isArgGenIndex && isNotArgContents && isNotArgIndex + result = + intercalate ", " + . map + ( \o -> + i outputDir + case o of + Html + | isIndexGenerated -> + "index.html" + Html + | otherwise -> + mempty + Hoogle -> pkgstr <.> "txt" + ) + . fromFlagOrDefault [Html] + . argOutput + $ args + where + pkgstr = prettyShow $ packageName pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] +renderPureArgs version comp platform args = + concat + [ map (\f -> "--dump-interface=" ++ u (unDir (argOutputDir args)) f) + . flagToList + . argInterfaceFile + $ args + , if haddockSupportsPackageName + then + maybe + [] + ( \pkg -> + [ "--package-name=" + ++ case argComponentName args of + Flag name -> name + _ -> prettyShow (pkgName pkg) + , "--package-version=" ++ prettyShow (pkgVersion pkg) + ] + ) + . flagToMaybe + . argPackageName + $ args + else [] + , ["--since-qual=external" | isVersion 2 20] + , [ "--quickjump" | isVersion 2 19, True <- flagToList . argQuickJump $ args + ] + , ["--hyperlinked-source" | isHyperlinkedSource] + , (\(All b, xs) -> bool [] (map (("--hide=" ++) . prettyShow) xs) b) + . argHideModules + $ args + , bool [] ["--ignore-all-exports"] . getAny . argIgnoreExports $ args + , -- Haddock's --source-* options are ignored once --hyperlinked-source is + -- set. + -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source + -- To avoid Haddock's warning, we only set --source-* options if + -- --hyperlinked-source is not set. + if isHyperlinkedSource + then [] + else + maybe + [] + ( \(m, e, l) -> + [ "--source-module=" ++ m + , "--source-entity=" ++ e + ] + ++ if isVersion 2 14 + then ["--source-entity-line=" ++ l] + else [] + ) + . flagToMaybe + . argLinkSource + $ args + , maybe [] ((: []) . ("--css=" ++)) . flagToMaybe . argCssFile $ args + , maybe [] ((: []) . ("--use-contents=" ++)) . flagToMaybe . argContents $ args + , bool [] ["--gen-contents"] . fromFlagOrDefault False . argGenContents $ args + , maybe [] ((: []) . ("--use-index=" ++)) . flagToMaybe . argIndex $ args + , bool [] ["--gen-index"] . fromFlagOrDefault False . argGenIndex $ args + , maybe [] ((: []) . ("--base-url=" ++)) . flagToMaybe . argBaseUrl $ args + , bool [verbosityFlag] [] . getAny . argVerbose $ args + , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") + . fromFlagOrDefault [] + . argOutput + $ args + , renderInterfaces . argInterfaces $ args + , (: []) . ("--odir=" ++) . u . unDir . argOutputDir $ args + , maybe + [] + ( (: []) + . ("--title=" ++) + . ( bool + id + (++ " (internal documentation)") + (getAny $ argIgnoreExports args) + ) + ) + . flagToMaybe + . argTitle + $ args + , [ "--optghc=" ++ opt | let opts = argGhcOptions args, opt <- renderGhcOptions comp platform opts + ] + , maybe [] (\l -> ["-B" ++ l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + , -- https://github.com/haskell/haddock/pull/547 + [ "--reexport=" ++ prettyShow r + | r <- argReexports args + , isVersion 2 19 + ] + , argTargets $ args + , maybe [] ((: []) . (resourcesDirFlag ++)) . flagToMaybe . argResourcesDir $ args + , -- Do not re-direct compilation output to a temporary directory (--no-tmp-comp-dir) + -- We pass this option by default to haddock to avoid recompilation + -- See Note [Hi Haddock Recompilation Avoidance] + ["--no-tmp-comp-dir" | version >= mkVersion [2, 28, 0]] + , bool [] ["--use-unicode"] . fromFlagOrDefault False . argUseUnicode $ args + ] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u = interpretSymbolicPathCWD + renderInterfaces = map renderInterface + + renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String + renderInterface (i, html, hypsrc, visibility) = + "--read-interface=" + ++ intercalate + "," + ( concat + [ [fromMaybe "" html] + , -- only render hypsrc path if html path + -- is given and hyperlinked-source is + -- enabled + + [ case (html, hypsrc) of + (Nothing, _) -> "" + (_, Nothing) -> "" + (_, Just x) + | isVersion 2 17 + , fromFlagOrDefault False . argLinkedSource $ args -> + x + | otherwise -> + "" + ] + , if haddockSupportsVisibility + then + [ case visibility of + Visible -> "visible" + Hidden -> "hidden" + ] + else [] + , [i] + ] + ) + + isVersion major minor = version >= mkVersion [major, minor] + verbosityFlag + | isVersion 2 5 = "--verbosity=1" + | otherwise = "--verbose" + resourcesDirFlag + | isVersion 2 29 = "--resources-dir=" + | otherwise = "--lib=" + haddockSupportsVisibility = version >= mkVersion [2, 26, 1] + haddockSupportsPackageName = version > mkVersion [2, 16] + haddockSupportsHyperlinkedSource = isVersion 2 17 + isHyperlinkedSource = + haddockSupportsHyperlinkedSource + && fromFlagOrDefault False (argLinkedSource args) + +--------------------------------------------------------------------------------- + +-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and +-- HTML paths, and an optional warning for packages with missing documentation. +haddockPackagePaths + :: [InstalledPackageInfo] + -> Maybe (InstalledPackageInfo -> FilePath) + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackagePaths ipkgs mkHtmlPath = do + interfaces <- + sequenceA + [ case interfaceAndHtmlPath ipkg of + Nothing -> do + return (Left (packageId ipkg)) + Just (interface, html) -> do + (html', hypsrc') <- + case html of + Just htmlPath -> do + let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory + hypSrcExists <- doesDirectoryExist hypSrcPath + return $ + ( Just (fixFileUrl htmlPath) + , if hypSrcExists + then Just (fixFileUrl hypSrcPath) + else Nothing + ) + Nothing -> return (Nothing, Nothing) + + exists <- doesFileExist interface + if exists + then return (Right (interface, html', hypsrc', Visible)) + else return (Left pkgid) + | ipkg <- ipkgs + , let pkgid = packageId ipkg + , pkgName pkgid `notElem` noHaddockWhitelist + ] + + let missing = [pkgid | Left pkgid <- interfaces] + warning = + "The following packages have no Haddock documentation " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map prettyShow missing) + flags = rights interfaces + + return (flags, if null missing then Nothing else Just warning) + where + -- Don't warn about missing documentation for these packages. See #1231. + noHaddockWhitelist = map mkPackageName ["rts"] + + -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. + interfaceAndHtmlPath + :: InstalledPackageInfo + -> Maybe (FilePath, Maybe FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case mkHtmlPath of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just mkPath -> Just (mkPath pkg) + return (interface, if null html then Nothing else Just html) + + -- The 'haddock-html' field in the hc-pkg output is often set as a + -- native path, but we need it as a URL. See #1064. Also don't "fix" + -- the path if it is an interpolated one. + fixFileUrl f + | Nothing <- mkHtmlPath + , isAbsolute f = + "file://" ++ f + | otherwise = f + + -- 'src' is the default hyperlinked source directory ever since. It is + -- not possible to configure that directory in any way in haddock. + defaultHyperlinkedSourceDirectory = "src" + +haddockPackageFlags + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackageFlags verbosity lbi clbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (componentPackageDeps clbi) + transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of + Left x -> return x + Right inf -> + dieWithException verbosity $ HaddockPackageFlags inf + + haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath + where + mkHtmlPath = fmap expandTemplateVars htmlTemplate + expandTemplateVars tmpl pkg = + fromPathTemplate . substPathTemplate (env pkg) $ tmpl + env pkg = haddockTemplateEnv lbi (packageId pkg) + +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = + (PrefixVar, prefix (installDirTemplates lbi)) + -- We want the legacy unit ID here, because it gives us nice paths + -- (Haddock people don't care about the dependencies) + : initialPathTemplateEnv + pkg_id + (mkLegacyUnitId pkg_id) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + +-- ------------------------------------------------------------------------------ +-- hscolour support. + +hscolour + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour = hscolour_setupHooks noBuildHooks + +hscolour_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour_setupHooks setupHooks = + hscolour' setupHooks dieNoVerbosity ForDevelopment + +hscolour' + :: BuildHooks + -> (String -> IO ()) + -- ^ Called when the 'hscolour' exe is not found. + -> HaddockTarget + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' + (BuildHooks{preBuildComponentRules = mbPbcRules}) + onNoHsColour + haddockTarget + pkg_descr + lbi + suffixes + flags = + either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + =<< lookupProgramVersion + verbosity + hscolourProgram + (orLaterVersion (mkVersion [1, 8])) + (withPrograms lbi) + where + common = hscolourCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref = fromFlag $ setupDistPref common + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + go :: ConfiguredProgram -> IO () + go hscolourProg = do + warn verbosity $ + "the 'cabal hscolour' command is deprecated in favour of 'cabal " + ++ "haddock --hyperlink-source' and will be removed in the next major " + ++ "release." + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + i $ + hscolourPref haddockTarget distPref pkg_descr + + withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do + let tgt = TargetInfo clbi comp + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 target = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHscolour flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = target + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi tgt + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + makeRelativePathEx (unUnqualComponentName (exeName exe) "src") + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi + Nothing -> do + warn verbosity "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi + CFLib flib -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + makeRelativePathEx + ( unUnqualComponentName (foreignLibName flib) + "src" + ) + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + runHsColour + :: ConfiguredProgram + -> SymbolicPath Pkg to + -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)] + -> IO () + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True (i outputDir) + + case stylesheet of -- copy the CSS file + Nothing + | programVersion prog >= Just (mkVersion [1, 9]) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-print-css", "-o" ++ u outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (i outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-css", "-anchor", "-o" ++ outFile m, u inFile] + where + outFile m = + i outputDir + intercalate "-" (ModuleName.components m) + <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags + { hscolourCommonFlags = haddockCommonFlags flags + , hscolourCSS = haddockHscolourCss flags + , hscolourExecutables = haddockExecutables flags + , hscolourTestSuites = haddockTestSuites flags + , hscolourBenchmarks = haddockBenchmarks flags + , hscolourForeignLibs = haddockForeignLibs flags + } + +-- ------------------------------------------------------------------------------ +-- Boilerplate Monoid instance. +instance Monoid HaddockArgs where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockArgs where + (<>) = gmappend + +instance Monoid Directory where + mempty = Dir "." + mappend = (<>) + +instance Semigroup Directory where + Dir m <> Dir n = Dir $ m n diff --git a/src/Distribution/Simple/Hpc.hs b/src/Distribution/Simple/Hpc.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Hpc.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- a function for adding the necessary options to a PackageDescription to +-- build test suites with HPC enabled. +module Distribution.Simple.Hpc + ( Way (..) + , guessWay + , htmlDir + , mixDir + , tixDir + , tixFilePath + , HPCMarkupInfo (..) + , markupPackage + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName (ModuleName, main) +import Distribution.PackageDescription + ( TestSuite (..) + , testModules + ) +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo (..) + , interpretSymbolicPathLBI + , mbWorkDirLBI + ) +import Distribution.Simple.Program + ( hpcProgram + , requireProgramVersion + ) +import Distribution.Simple.Program.Hpc (markup, union) +import Distribution.Simple.Utils (notice) +import Distribution.Types.UnqualComponentName +import Distribution.Utils.Path +import Distribution.Verbosity (Verbosity ()) +import Distribution.Version (anyVersion) + +import System.Directory (createDirectoryIfMissing, doesFileExist) + +-- ------------------------------------------------------------------------- +-- Haskell Program Coverage + +data Way = Vanilla | Prof | Dyn | ProfDyn + deriving (Bounded, Enum, Eq, Read, Show) + +hpcDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Directory containing component's HPC .mix files +hpcDir distPref way = distPref makeRelativePathEx ("hpc" wayDir) + where + wayDir = case way of + Vanilla -> "vanilla" + Prof -> "prof" + Dyn -> "dyn" + ProfDyn -> "prof_dyn" + +mixDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Mix) + -- ^ Directory containing test suite's .mix files +mixDir distPref way = hpcDir distPref way makeRelativePathEx "mix" + +tixDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Tix) + -- ^ Directory containing test suite's .tix files +tixDir distPref way = hpcDir distPref way makeRelativePathEx "tix" + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> SymbolicPath Pkg File + -- ^ Path to test suite's .tix file +tixFilePath distPref way name = tixDir distPref way makeRelativePathEx (name <.> "tix") + +htmlDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Path to test suite's HTML markup directory +htmlDir distPref way = hpcDir distPref way makeRelativePathEx "html" + +-- | Attempt to guess the way the test suites in this package were compiled +-- and linked with the library so the correct module interfaces are found. +guessWay :: LocalBuildInfo -> Way +guessWay lbi + | withProfExe lbi = Prof + | withDynExe lbi = Dyn + | otherwise = Vanilla + +-- | Haskell Program Coverage information required to produce a valid HPC +-- report through the `hpc markup` call for the package libraries. +data HPCMarkupInfo = HPCMarkupInfo + { pathsToLibsArtifacts :: [SymbolicPath Pkg (Dir Artifacts)] + -- ^ The paths to the library components whose modules are included in the + -- coverage report + , libsModulesToInclude :: [ModuleName] + -- ^ The modules to include in the coverage report + } + +-- | Generate the HTML markup for a package's test suites. +markupPackage + :: Verbosity + -> HPCMarkupInfo + -> LocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -- ^ Testsuite \"dist/\" prefix + -> PD.PackageDescription + -> [TestSuite] + -> IO () +markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do + let tixFiles = map (tixFilePath testDistPref way) testNames + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + tixFilesExist <- traverse (doesFileExist . i) tixFiles + when (and tixFilesExist) $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- + requireProgramVersion + verbosity + hpcProgram + anyVersion + (withPrograms lbi) + let htmlDir' = htmlDir testDistPref way + -- The tix file used to generate the report is either the testsuite's + -- tix file, when there is only one testsuite, or the sum of the tix + -- files of all testsuites in the package, which gets put under pkgName + -- for this component (a bit weird) + -- TODO: cabal-install should pass to Cabal where to put the summed tix + -- and report, and perhaps even the testsuites from other packages in + -- the project which are currently not accounted for in the summed + -- report. + tixFile <- case suites of + -- We call 'markupPackage' once for each testsuite to run individually, + -- to get the coverage report of just the one testsuite + [oneTest] -> do + let testName' = unUnqualComponentName $ testName oneTest + return $ + tixFilePath testDistPref way testName' + -- And call 'markupPackage' once per `test` invocation with all the + -- testsuites to run, which results in multiple tix files being considered + _ -> do + let excluded = concatMap testModules suites ++ [main] + pkgName = prettyShow $ PD.package pkg_descr + summedTixFile = tixFilePath testDistPref way pkgName + createDirectoryIfMissing True $ i $ takeDirectorySymbolicPath summedTixFile + union mbWorkDir hpc verbosity tixFiles summedTixFile excluded + return summedTixFile + + markup mbWorkDir hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude + notice verbosity $ + "Package coverage report written to " + ++ i htmlDir' + "hpc_index.html" + where + way = guessWay lbi + testNames = fmap (unUnqualComponentName . testName) suites + mixDirs = map ((`mixDir` way) . coerceSymbolicPath) pathsToLibsArtifacts diff --git a/src/Distribution/Simple/Install.hs b/src/Distribution/Simple/Install.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Install.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- place based on the prefix argument. It does the generic bits and then calls +-- compiler-specific functions to do the rest. +module Distribution.Simple.Install + ( install + , install_setupHooks + , installFileGlob + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion (CabalSpecVersion) + +import Distribution.Types.ExecutableScope +import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageDescription +import Distribution.Types.TargetInfo +import Distribution.Types.UnqualComponentName + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths (haddockPath, haddockPref) +import Distribution.Simple.BuildTarget +import Distribution.Simple.Compiler + ( CompilerFlavor (..) + , compilerFlavor + ) +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Copy + ( CopyFlags (..) + ) +import Distribution.Simple.Setup.Haddock + ( HaddockTarget (ForDevelopment) + ) +import Distribution.Simple.SetupHooks.Internal + ( InstallHooks (..) + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , dieWithException + , info + , installDirectoryContents + , installOrdinaryFile + , isAbsoluteOnAnyPlatform + , isInSearchPath + , noticeNoWrap + , warn + ) +import Distribution.Utils.Path + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Simple.Errors +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import Distribution.Simple.Setup.Common +import qualified Distribution.Simple.UHC as UHC + +import System.Directory + ( doesDirectoryExist + , doesFileExist + ) +import System.FilePath + ( takeDirectory + , takeFileName + ) + +import Distribution.Pretty + ( prettyShow + ) +import Distribution.Verbosity + +-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. +-- +-- This does NOT register libraries, you should call 'register' +-- to do that. +install + :: PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () +install = install_setupHooks SetupHooks.noInstallHooks + +install_setupHooks + :: InstallHooks + -> PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () +install_setupHooks + (InstallHooks{installComponentHook}) + pkg_descr + lbi + flags = do + checkHasLibsOrExes + targets <- readTargetInfos verbosity pkg_descr lbi (copyTargets flags) + + copyPackage verbosity pkg_descr lbi distPref copydest + + -- It's not necessary to do these in build-order, but it's harmless + withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> do + let comp = targetComponent target + clbi = targetCLBI target + copyComponent verbosity pkg_descr lbi comp clbi copydest + for_ installComponentHook $ \instAction -> + let inputs = + SetupHooks.InstallComponentInputs + { copyFlags = flags + , localBuildInfo = lbi + , targetInfo = target + } + in instAction inputs + where + common = copyCommonFlags flags + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common + copydest = fromFlag (copyDest flags) + + checkHasLibsOrExes = + unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ + warn verbosity "No executables and no library found. Nothing to do." + +-- | Copy package global files. +copyPackage + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> CopyDest + -> IO () +copyPackage verbosity pkg_descr lbi distPref copydest = do + let + -- This is a bit of a hack, to handle files which are not + -- per-component (data files and Haddock files.) + InstallDirs + { datadir = dataPref + , docdir = docPref + , htmldir = htmlPref + , haddockdir = interfacePref + } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + + -- Install (package-global) data files + installDataFiles verbosity mbWorkDir pkg_descr $ makeSymbolicPath dataPref + + -- Install (package-global) Haddock files + -- TODO: these should be done per-library + docExists <- doesDirectoryExist $ i $ haddockPref ForDevelopment distPref pkg_descr + info + verbosity + ( "directory " + ++ getSymbolicPath (haddockPref ForDevelopment distPref pkg_descr) + ++ " does exist: " + ++ show docExists + ) + + -- TODO: this is a bit questionable, Haddock files really should + -- be per library (when there are convenience libraries.) + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents + verbosity + (i $ haddockPref ForDevelopment distPref pkg_descr) + htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = + haddockPref ForDevelopment distPref pkg_descr + makeRelativePathEx (haddockPath pkg_descr) + haddockInterfaceFileDest = interfacePref haddockPath pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist $ i haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile + verbosity + (i haddockInterfaceFileSrc) + haddockInterfaceFileDest + + let lfiles = licenseFiles pkg_descr + unless (null lfiles) $ do + createDirectoryIfMissingVerbose verbosity True docPref + for_ lfiles $ \lfile -> do + installOrdinaryFile + verbosity + (i lfile) + (docPref takeFileName (getSymbolicPath lfile)) + +-- | Copy files associated with a component. +copyComponent + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Component + -> ComponentLocalBuildInfo + -> CopyDest + -> IO () +copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do + let InstallDirs + { libdir = libPref + , dynlibdir = dynlibPref + , includedir = incPref + } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi + + case libName lib of + LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) + LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + + case compilerFlavor (compiler lbi) of + GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + _ -> + dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) +copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do + let InstallDirs + { flibdir = flibPref + , includedir = incPref + } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi + + noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) + installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + + case compilerFlavor (compiler lbi) of + GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib + GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib + _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) +copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do + let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + -- the installers know how to find the actual location of the + -- binaries + buildPref = interpretSymbolicPathLBI lbi $ buildDir lbi + uid = componentUnitId clbi + pkgid = packageId pkg_descr + binPref + | ExecutablePrivate <- exeScope exe = libexecdir installDirs + | otherwise = bindir installDirs + progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) + progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) + progFix = (progPrefixPref, progSuffixPref) + noticeNoWrap + verbosity + ( "Installing executable " + ++ prettyShow (exeName exe) + ++ " in " + ++ binPref + ) + inPath <- isInSearchPath binPref + when (not inPath) $ + warn + verbosity + ( "The directory " + ++ binPref + ++ " is not in the system search path." + ) + case compilerFlavor (compiler lbi) of + GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + UHC -> return () + _ -> + dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) + +-- Nothing to do for benchmark/testsuite +copyComponent _ _ _ (CBench _) _ _ = return () +copyComponent _ _ _ (CTest _) _ _ = return () + +-- | Install the files listed in data-files +installDataFiles + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDescription + -> SymbolicPath Pkg (Dir DataDir) + -> IO () +installDataFiles verbosity mbWorkDir pkg_descr destDataDir = + traverse_ + (installFileGlob verbosity (specVersion pkg_descr) mbWorkDir (srcDataDir, destDataDir)) + (dataFiles pkg_descr) + where + srcDataDirRaw = getSymbolicPath $ dataDir pkg_descr + srcDataDir :: Maybe (SymbolicPath CWD (Dir DataDir)) + srcDataDir + | null srcDataDirRaw = + Nothing + | isAbsoluteOnAnyPlatform srcDataDirRaw = + Just $ makeSymbolicPath srcDataDirRaw + | otherwise = + Just $ fromMaybe sameDirectory mbWorkDir makeRelativePathEx srcDataDirRaw + +-- | Install the files specified by the given glob pattern. +installFileGlob + :: Verbosity + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> (Maybe (SymbolicPath CWD (Dir DataDir)), SymbolicPath Pkg (Dir DataDir)) + -- ^ @(src_dir, dest_dir)@ + -> RelativePath DataDir File + -- ^ file glob pattern + -> IO () +installFileGlob verbosity spec_version mbWorkDir (srcDir, destDir) glob = do + files <- matchDirFileGlob verbosity spec_version srcDir glob + for_ files $ \file' -> do + let src = getSymbolicPath (fromMaybe sameDirectory srcDir file') + dst = interpretSymbolicPath mbWorkDir (destDir file') + createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) + installOrdinaryFile verbosity src dst + +-- | Install the files listed in install-includes for a library +installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () +installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do + let relincdirs = sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs libBi) + incdirs = + [ root getSymbolicPath dir + | -- NB: both baseDir and buildPref are already interpreted, + -- so we don't need to interpret these paths in the call to findInc. + dir <- relincdirs + , root <- [baseDir lbi, buildPref] + ] + incs <- traverse (findInc incdirs . getSymbolicPath) (installIncludes libBi) + sequence_ + [ do + createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile + ] + where + baseDir lbi' = packageRoot $ configCommonFlags $ configFlags lbi' + findInc [] file = dieWithException verbosity $ CantFindIncludeFile file + findInc (dir : dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file diff --git a/src/Distribution/Simple/InstallDirs.hs b/src/Distribution/Simple/InstallDirs.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/InstallDirs.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- provides a 'PathTemplate' type and functions for substituting for these +-- templates. +module Distribution.Simple.InstallDirs + ( InstallDirs (..) + , InstallDirTemplates + , defaultInstallDirs + , defaultInstallDirs' + , combineInstallDirs + , absoluteInstallDirs + , CopyDest (..) + , prefixRelativeInstallDirs + , substituteInstallDirTemplates + , PathTemplate + , PathTemplateVariable (..) + , PathTemplateEnv + , toPathTemplate + , fromPathTemplate + , combinePathTemplate + , substPathTemplate + , initialPathTemplateEnv + , platformTemplateEnv + , compilerTemplateEnv + , packageTemplateEnv + , abiTemplateEnv + , installDirsTemplateEnv + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Compiler +import Distribution.Package +import Distribution.Pretty +import Distribution.Simple.InstallDirs.Internal +import Distribution.System + +import System.Directory (getAppUserDataDirectory) +import System.FilePath + ( dropDrive + , isPathSeparator + , pathSeparator + , takeDirectory + , () + ) + +#ifdef mingw32_HOST_OS +import qualified Prelude +import Foreign +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Installation directories + +-- | The directories where we will install files for packages. +-- +-- We have several different directories for different types of files since +-- many systems have conventions whereby different types of files in a package +-- are installed in different directories. This is particularly the case on +-- Unix style systems. +data InstallDirs dir = InstallDirs + { prefix :: dir + , bindir :: dir + , libdir :: dir + , libsubdir :: dir + , dynlibdir :: dir + , flibdir :: dir + -- ^ foreign libraries + , libexecdir :: dir + , libexecsubdir :: dir + , includedir :: dir + , datadir :: dir + , datasubdir :: dir + , docdir :: dir + , mandir :: dir + , htmldir :: dir + , haddockdir :: dir + , sysconfdir :: dir + } + deriving (Eq, Read, Show, Functor, Generic) + +instance Binary dir => Binary (InstallDirs dir) +instance Structured dir => Structured (InstallDirs dir) + +instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where + mempty = gmempty + mappend = (<>) + +instance Semigroup dir => Semigroup (InstallDirs dir) where + (<>) = gmappend + +combineInstallDirs + :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = + InstallDirs + { prefix = prefix a `combine` prefix b + , bindir = bindir a `combine` bindir b + , libdir = libdir a `combine` libdir b + , libsubdir = libsubdir a `combine` libsubdir b + , dynlibdir = dynlibdir a `combine` dynlibdir b + , flibdir = flibdir a `combine` flibdir b + , libexecdir = libexecdir a `combine` libexecdir b + , libexecsubdir = libexecsubdir a `combine` libexecsubdir b + , includedir = includedir a `combine` includedir b + , datadir = datadir a `combine` datadir b + , datasubdir = datasubdir a `combine` datasubdir b + , docdir = docdir a `combine` docdir b + , mandir = mandir a `combine` mandir b + , htmldir = htmldir a `combine` htmldir b + , haddockdir = haddockdir a `combine` haddockdir b + , sysconfdir = sysconfdir a `combine` sysconfdir b + } + +appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs append dirs = + dirs + { libdir = libdir dirs `append` libsubdir dirs + , libexecdir = libexecdir dirs `append` libexecsubdir dirs + , datadir = datadir dirs `append` datasubdir dirs + , libsubdir = error "internal error InstallDirs.libsubdir" + , libexecsubdir = error "internal error InstallDirs.libexecsubdir" + , datasubdir = error "internal error InstallDirs.datasubdir" + } + +-- | The installation directories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- convenient for the user to override the default installation directory +-- by only having to specify --prefix=... rather than overriding each +-- individually. This is done by allowing $-style variables in the dirs. +-- These are expanded by textual substitution (see 'substPathTemplate'). +-- +-- A few of these installation directories are split into two components, the +-- dir and subdir. The full installation path is formed by combining the two +-- together with @\/@. The reason for this is compatibility with other Unix +-- build systems which also support @--libdir@ and @--datadir@. We would like +-- users to be able to configure @--libdir=\/usr\/lib64@ for example but +-- because by default we want to support installing multiple versions of +-- packages and building the same package for multiple compilers we append the +-- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@. +-- +-- An additional complication is the need to support relocatable packages on +-- systems which support such things, like Windows. +type InstallDirTemplates = InstallDirs PathTemplate + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs = defaultInstallDirs' False + +defaultInstallDirs' + :: Bool {- use external internal deps -} + -> CompilerFlavor + -> Bool + -> Bool + -> IO InstallDirTemplates +defaultInstallDirs' True comp userInstall hasLibs = do + dflt <- defaultInstallDirs' False comp userInstall hasLibs + -- Be a bit more hermetic about per-component installs + return + dflt + { datasubdir = toPathTemplate $ "$abi" "$libname" + , docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" + } +defaultInstallDirs' False comp userInstall _hasLibs = do + installPrefix <- + if userInstall + then do + mDir <- lookupEnv "CABAL_DIR" + case mDir of + Nothing -> getAppUserDataDirectory "cabal" + Just dir -> return dir + else case buildOS of + Windows -> do + windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + Haiku -> return "/boot/system/non-packaged" + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> return ("$prefix" "lib") + return $ + fmap toPathTemplate $ + InstallDirs + { prefix = installPrefix + , bindir = "$prefix" "bin" + , libdir = installLibDir + , libsubdir = case comp of + UHC -> "$pkgid" + _other -> "$abi" "$libname" + , dynlibdir = + "$libdir" case comp of + UHC -> "$pkgid" + _other -> "$abi" + , libexecsubdir = "$abi" "$pkgid" + , flibdir = "$libdir" + , libexecdir = case buildOS of + Windows -> "$prefix" "$libname" + Haiku -> "$libdir" + _other -> "$prefix" "libexec" + , includedir = case buildOS of + Haiku -> "$prefix" "develop" "headers" + _other -> "$libdir" "$libsubdir" "include" + , datadir = case buildOS of + Windows -> "$prefix" + Haiku -> "$prefix" "data" + _other -> "$prefix" "share" + , datasubdir = "$abi" "$pkgid" + , docdir = case buildOS of + Haiku -> "$prefix" "documentation" + _other -> "$datadir" "doc" "$abi" "$pkgid" + , mandir = case buildOS of + Haiku -> "$docdir" "man" + _other -> "$datadir" "man" + , htmldir = "$docdir" "html" + , haddockdir = "$htmldir" + , sysconfdir = case buildOS of + Haiku -> "boot" "system" "settings" + _other -> "$prefix" "etc" + } + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- as a subsequent operation. +-- +-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we +-- can replace 'prefix' with the 'PrefixVar' and get resulting +-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it +-- each to check which paths are relative to the $prefix. +substituteInstallDirTemplates + :: PathTemplateEnv + -> InstallDirTemplates + -> InstallDirTemplates +substituteInstallDirTemplates env dirs = dirs' + where + dirs' = + InstallDirs + { -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [] + , bindir = subst bindir [prefixVar] + , libdir = subst libdir [prefixVar, bindirVar] + , libsubdir = subst libsubdir [] + , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar] + , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar] + , libexecdir = subst libexecdir prefixBinLibVars + , libexecsubdir = subst libexecsubdir [] + , includedir = subst includedir prefixBinLibVars + , datadir = subst datadir prefixBinLibVars + , datasubdir = subst datasubdir [] + , docdir = subst docdir prefixBinLibDataVars + , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]) + , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]) + , haddockdir = + subst + haddockdir + ( prefixBinLibDataVars + ++ [docdirVar, htmldirVar] + ) + , sysconfdir = subst sysconfdir prefixBinLibVars + } + subst dir env' = substPathTemplate (env' ++ env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') + prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] + prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] + +-- | Convert from abstract install directories to actual absolute ones by +-- substituting for all the variables in the abstract paths, to get real +-- absolute path. +absoluteInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> CopyDest + -> Platform + -> InstallDirs PathTemplate + -> InstallDirs FilePath +absoluteInstallDirs pkgId libname compilerId copydest platform dirs = + ( case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) + _ -> id + ) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs + where + env = initialPathTemplateEnv pkgId libname compilerId platform + substPrefix pre root path + | pre `isPrefixOf` path = root ++ drop (length pre) path + | otherwise = path + +-- | The location prefix for the /copy/ command. +data CopyDest + = NoCopyDest + | CopyTo FilePath + | -- | when using the ${pkgroot} as prefix. The CopyToDb will + -- adjust the paths to be relative to the provided package + -- database when copying / installing. + CopyToDb FilePath + deriving (Eq, Show, Generic) + +-- TODO: are these paths absolute or relative? Relative to what? + +instance Binary CopyDest +instance Structured CopyDest + +-- | Check which of the paths are relative to the installation $prefix. +-- +-- If any of the paths are not relative, ie they are absolute paths, then it +-- prevents us from making a relocatable package (also known as a \"prefix +-- independent\" package). +prefixRelativeInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkgId libname compilerId platform dirs = + fmap relative + . appendSubdirs combinePathTemplate + $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map + -- \$prefix back to $prefix. We're trying to end up with templates that + -- mention no vars except $prefix. + env + dirs + { prefix = PathTemplate [Variable PrefixVar] + } + where + env = initialPathTemplateEnv pkgId libname compilerId platform + + -- If it starts with $prefix then it's relative and produce the relative + -- path by stripping off $prefix/ or $prefix + relative dir = case dir of + PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) + relative' (Variable PrefixVar : Ordinary (s : rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : rest) = Just rest + relative' _ = Nothing + +-- --------------------------------------------------------------------------- +-- Path templates + +-- | An abstract path, possibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +newtype PathTemplate = PathTemplate [PathComponent] + deriving (Eq, Ord, Generic) + +instance Binary PathTemplate +instance Structured PathTemplate + +type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate fp = + PathTemplate + . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) + . readMaybe -- TODO: eradicateNoParse + $ fp + +-- | Convert back to a path, any remaining vars are included +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate template) = show template + +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate +combinePathTemplate (PathTemplate t1) (PathTemplate t2) = + PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) + +substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + where + subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> PathTemplateEnv +initialPathTemplateEnv pkgId libname compiler platform = + packageTemplateEnv pkgId libname + ++ compilerTemplateEnv compiler + ++ platformTemplateEnv platform + ++ abiTemplateEnv compiler platform + +packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv +packageTemplateEnv pkgId uid = + [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) + , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) + , -- Invariant: uid is actually a HashedUnitId. Hard to enforce because + -- it's an API change. + (LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) + , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) + ] + +compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv +compilerTemplateEnv compiler = + [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) + ] + +platformTemplateEnv :: Platform -> PathTemplateEnv +platformTemplateEnv (Platform arch os) = + [ (OSVar, PathTemplate [Ordinary $ prettyShow os]) + , (ArchVar, PathTemplate [Ordinary $ prettyShow arch]) + ] + +abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv +abiTemplateEnv compiler (Platform arch os) = + [ + ( AbiVar + , PathTemplate + [ Ordinary $ + prettyShow arch + ++ '-' + : prettyShow os + ++ '-' + : prettyShow (compilerInfoId compiler) + ++ case compilerInfoAbiTag compiler of + NoAbiTag -> "" + AbiTag tag -> '-' : tag + ] + ) + , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) + ] + +installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv +installDirsTemplateEnv dirs = + [ (PrefixVar, prefix dirs) + , (BindirVar, bindir dirs) + , (LibdirVar, libdir dirs) + , (LibsubdirVar, libsubdir dirs) + , (DynlibdirVar, dynlibdir dirs) + , (DatadirVar, datadir dirs) + , (DatasubdirVar, datasubdir dirs) + , (DocdirVar, docdir dirs) + , (HtmldirVar, htmldir dirs) + ] + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = + [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path + ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +{- FOURMOLU_DISABLE -} +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#ifdef mingw32_HOST_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) +{- FOURMOLU_ENABLE -} + +#ifdef mingw32_HOST_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = + allocaArray long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCWString pPath; return (Just s) + where + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty + +csidl_PROGRAM_FILES :: CInt +csidl_PROGRAM_FILES = 0x0026 +-- csidl_PROGRAM_FILES_COMMON :: CInt +-- csidl_PROGRAM_FILES_COMMON = 0x002b + +{- FOURMOLU_DISABLE -} +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CWString + -> Prelude.IO CInt +#endif +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Simple/InstallDirs/Internal.hs b/src/Distribution/Simple/InstallDirs/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/InstallDirs/Internal.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Simple.InstallDirs.Internal + ( PathComponent (..) + , PathTemplateVariable (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +data PathComponent + = Ordinary FilePath + | Variable PathTemplateVariable + deriving (Eq, Ord, Generic) + +instance Binary PathComponent +instance Structured PathComponent + +data PathTemplateVariable + = -- | The @$prefix@ path variable + PrefixVar + | -- | The @$bindir@ path variable + BindirVar + | -- | The @$libdir@ path variable + LibdirVar + | -- | The @$libsubdir@ path variable + LibsubdirVar + | -- | The @$dynlibdir@ path variable + DynlibdirVar + | -- | The @$datadir@ path variable + DatadirVar + | -- | The @$datasubdir@ path variable + DatasubdirVar + | -- | The @$docdir@ path variable + DocdirVar + | -- | The @$htmldir@ path variable + HtmldirVar + | -- | The @$pkg@ package name path variable + PkgNameVar + | -- | The @$version@ package version path variable + PkgVerVar + | -- | The @$pkgid@ package Id path variable, eg @foo-1.0@ + PkgIdVar + | -- | The @$libname@ path variable + LibNameVar + | -- | The compiler name and version, eg @ghc-6.6.1@ + CompilerVar + | -- | The operating system name, eg @windows@ or @linux@ + OSVar + | -- | The CPU architecture name, eg @i386@ or @x86_64@ + ArchVar + | -- | The compiler's ABI identifier, + AbiVar + | --- $arch-$os-$compiler-$abitag + + -- | The optional ABI tag for the compiler + AbiTagVar + | -- | The executable name; used in shell wrappers + ExecutableNameVar + | -- | The name of the test suite being run + TestSuiteNameVar + | -- | The result of the test suite being run, eg + -- @pass@, @fail@, or @error@. + TestSuiteResultVar + | -- | The name of the benchmark being run + BenchmarkNameVar + deriving (Eq, Ord, Generic) + +instance Binary PathTemplateVariable +instance Structured PathTemplateVariable + +instance Show PathTemplateVariable where + show PrefixVar = "prefix" + show LibNameVar = "libname" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DynlibdirVar = "dynlibdir" + show DatadirVar = "datadir" + show DatasubdirVar = "datasubdir" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show AbiTagVar = "abitag" + show AbiVar = "abi" + show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" + show BenchmarkNameVar = "benchmark" + +instance Read PathTemplateVariable where + readsPrec _ s = + take + 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s + ] + where + -- NB: order matters! Longer strings first + vars = + [ ("prefix", PrefixVar) + , ("bindir", BindirVar) + , ("libdir", LibdirVar) + , ("libsubdir", LibsubdirVar) + , ("dynlibdir", DynlibdirVar) + , ("datadir", DatadirVar) + , ("datasubdir", DatasubdirVar) + , ("docdir", DocdirVar) + , ("htmldir", HtmldirVar) + , ("pkgid", PkgIdVar) + , ("libname", LibNameVar) + , ("pkgkey", LibNameVar) -- backwards compatibility + , ("pkg", PkgNameVar) + , ("version", PkgVerVar) + , ("compiler", CompilerVar) + , ("os", OSVar) + , ("arch", ArchVar) + , ("abitag", AbiTagVar) + , ("abi", AbiVar) + , ("executablename", ExecutableNameVar) + , ("test-suite", TestSuiteNameVar) + , ("result", TestSuiteResultVar) + , ("benchmark", BenchmarkNameVar) + ] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$' : show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we collapse multiple $ symbols here + readsPrec _ = lex0 + where + lex0 [] = [] + lex0 ('$' : '$' : s') = lex0 ('$' : s') + lex0 ('$' : s') = case [ (Variable var, s'') + | (var, s'') <- reads s' + ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$' : '$' : s) = lex1 acc ('$' : s) + lex1 acc ('$' : s) = [(Ordinary (reverse acc), '$' : s)] + lex1 acc (c : s) = lex1 (c : acc) s + readList [] = [([], "")] + readList s = + [ (component : components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' + ] diff --git a/src/Distribution/Simple/LocalBuildInfo.hs b/src/Distribution/Simple/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/LocalBuildInfo.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets +-- passed in to very many subsequent build actions. +module Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo (..) + , localComponentId + , localUnitId + , localCompatPackageKey + + -- * Convenience accessors + , buildDir + , packageRoot + , progPrefix + , progSuffix + , interpretSymbolicPathLBI + , mbWorkDirLBI + , absoluteWorkingDirLBI + , buildWays + + -- * Buildable package components + , Component (..) + , ComponentName (..) + , LibraryName (..) + , defaultLibName + , showComponentName + , componentNameString + , ComponentLocalBuildInfo (..) + , componentBuildDir + , foldComponent + , componentName + , componentBuildInfo + , componentBuildable + , pkgComponents + , pkgBuildableComponents + , lookupComponent + , getComponent + , allComponentsInBuildOrder + , depLibraryPaths + , allLibModules + , withAllComponentsInBuildOrder + , withLibLBI + , withExeLBI + , withBenchLBI + , withTestLBI + , enabledTestLBIs + , enabledBenchLBIs + + -- * Installation directories + , module Distribution.Simple.InstallDirs + , absoluteInstallDirs + , prefixRelativeInstallDirs + , absoluteInstallCommandDirs + , absoluteComponentInstallDirs + , prefixRelativeComponentInstallDirs + , substPathTemplate + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName +import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageDescription +import Distribution.Types.PackageId +import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.Graph as Graph +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.PackageIndex +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.Simple.Utils +import Distribution.Utils.Path + +import Data.List (stripPrefix) +import qualified System.Directory as Directory + ( canonicalizePath + , doesDirectoryExist + ) + +-- ----------------------------------------------------------------------------- +-- Configuration information of buildable components + +componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Build) +-- For now, we assume that libraries/executables/test-suites/benchmarks +-- are only ever built once. With Backpack, we need a special case for +-- libraries so that we can handle building them multiple times. +componentBuildDir lbi clbi = + (buildDir lbi ) $ + makeRelativePathEx $ + case componentLocalName clbi of + CLibName LMainLibName -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then "" + else prettyShow (componentUnitId clbi) + CLibName (LSubLibName s) -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then unUnqualComponentName s + else prettyShow (componentUnitId clbi) + CFLibName s -> unUnqualComponentName s + CExeName s -> unUnqualComponentName s + CTestName s -> unUnqualComponentName s + CBenchName s -> unUnqualComponentName s + +-- | Interpret a symbolic path with respect to the working directory +-- stored in 'LocalBuildInfo'. +-- +-- Use this before directly interacting with the file system. +-- +-- NB: when invoking external programs (such as @GHC@), it is preferable to set +-- the working directory of the process rather than calling this function, as +-- this function will turn relative paths into absolute paths if the working +-- directory is an absolute path. This can degrade error messages, or worse, +-- break the behaviour entirely (because the program might expect certain paths +-- to be relative). +-- +-- See Note [Symbolic paths] in Distribution.Utils.Path +interpretSymbolicPathLBI :: LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath +interpretSymbolicPathLBI lbi = + interpretSymbolicPath (mbWorkDirLBI lbi) + +-- | Retrieve an optional working directory from 'LocalBuildInfo'. +mbWorkDirLBI :: LocalBuildInfo -> Maybe (SymbolicPath CWD (Dir Pkg)) +mbWorkDirLBI = + flagToMaybe . setupWorkingDir . configCommonFlags . configFlags + +-- | Absolute path to the current working directory. +absoluteWorkingDirLBI :: LocalBuildInfo -> IO (AbsolutePath (Dir Pkg)) +absoluteWorkingDirLBI lbi = absoluteWorkingDir (mbWorkDirLBI lbi) + +-- | Perform the action on each enabled 'library' in the package +-- description with the 'ComponentLocalBuildInfo'. +withLibLBI + :: PackageDescription + -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withLibLBI pkg lbi f = + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CLib lib -> f lib (targetCLBI target) + _ -> return () + +-- | Perform the action on each enabled 'Executable' in the package +-- description. Extended version of 'withExe' that also gives corresponding +-- build info. +withExeLBI + :: PackageDescription + -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withExeLBI pkg lbi f = + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CExe exe -> f exe (targetCLBI target) + _ -> return () + +-- | Perform the action on each enabled 'Benchmark' in the package +-- description. +withBenchLBI + :: PackageDescription + -> LocalBuildInfo + -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withBenchLBI pkg lbi f = + sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi] + +withTestLBI + :: PackageDescription + -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withTestLBI pkg lbi f = + sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi] + +enabledTestLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(TestSuite, ComponentLocalBuildInfo)] +enabledTestLBIs pkg lbi = + [ (test, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CTest test <- [targetComponent target] + ] + +enabledBenchLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(Benchmark, ComponentLocalBuildInfo)] +enabledBenchLBIs pkg lbi = + [ (bench, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CBench bench <- [targetComponent target] + ] + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withAllComponentsInBuildOrder + :: PackageDescription + -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withAllComponentsInBuildOrder pkg lbi f = + withAllTargetsInBuildOrder' pkg lbi $ \target -> + f (targetComponent target) (targetCLBI target) + +allComponentsInBuildOrder + :: LocalBuildInfo + -> [ComponentLocalBuildInfo] +allComponentsInBuildOrder (LocalBuildInfo{componentGraph = compGraph}) = + Graph.topSort compGraph + +-- ----------------------------------------------------------------------------- +-- A random function that has no business in this module + +-- | Determine the directories containing the dynamic libraries of the +-- transitive dependencies of the component we are building. +-- +-- When wanted, and possible, returns paths relative to the installDirs 'prefix' +depLibraryPaths + :: Bool + -- ^ Building for inplace? + -> Bool + -- ^ Generate prefix-relative library paths + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component that is being built + -> IO [FilePath] +depLibraryPaths + inplace + relative + lbi@( LocalBuildInfo + { localPkgDescr = pkgDescr + , installedPkgs = installed + } + ) + clbi = do + let installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest + executable = case clbi of + ExeComponentLocalBuildInfo{} -> True + _ -> False + relDir + | executable = bindir installDirs + | otherwise = libdir installDirs + + let + -- TODO: this is kind of inefficient + internalDeps = + [ uid + | (uid, _) <- componentPackageDeps clbi + , -- Test that it's internal + sub_target <- allTargetsInBuildOrder' pkgDescr lbi + , componentUnitId (targetCLBI (sub_target)) == uid + ] + internalLibs = + [ getLibDir (targetCLBI sub_target) + | sub_target <- + neededTargetsInBuildOrder' + pkgDescr + lbi + internalDeps + ] + {- + -- This is better, but it doesn't work, because we may be passed a + -- CLBI which doesn't actually exist, and was faked up when we + -- were building a test suite/benchmark. See #3599 for proposal + -- to fix this. + let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) + . map targetCLBI + $ neededTargetsInBuildOrder lbi [componentUnitId clbi] + internalLibs = map getLibDir internalCLBIs + -} + getLibDir sub_clbi + | inplace = interpretSymbolicPathLBI lbi $ componentBuildDir lbi sub_clbi + | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) + + -- Why do we go through all the trouble of a hand-crafting + -- internalLibs, when 'installedPkgs' actually contains the + -- internal libraries? The trouble is that 'installedPkgs' + -- may contain *inplace* entries, which we must NOT use for + -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation). + -- See #4025 for more details. This is all horrible but it + -- is a moot point if you are using a per-component build, + -- because you never have any internal libraries in this case; + -- they're all external. + let external_ipkgs = filter is_external (allPackages installed) + is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) + -- First look for dynamic libraries in `dynamic-library-dirs`, and use + -- `library-dirs` as a fall back. + getDynDir pkg = case Installed.libraryDynDirs pkg of + [] -> Installed.libraryDirs pkg + d -> d + allDepLibDirs = concatMap getDynDir external_ipkgs + + allDepLibDirs' = internalLibs ++ allDepLibDirs + allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' + + let p = prefix installDirs + prefixRelative l = isJust (stripPrefix p l) + libPaths + | relative + && prefixRelative relDir = + map + ( \l -> + if prefixRelative l + then shortRelativePath relDir l + else l + ) + allDepLibDirsC + | otherwise = allDepLibDirsC + + -- For some reason, this function returns lots of duplicates. Avoid + -- exceeding `ARG_MAX` (the result of this function is used to populate + -- `LD_LIBRARY_PATH`) by deduplicating the list. + return $ ordNub libPaths + where + -- 'canonicalizePath' fails on UNIX when the directory does not exists. + -- So just don't canonicalize when it doesn't exist. + canonicalizePathNoFail p = do + exists <- Directory.doesDirectoryExist p + if exists + then Directory.canonicalizePath p + else return p + +-- | Get all module names that needed to be built by GHC; i.e., all +-- of these 'ModuleName's have interface files associated with them +-- that need to be installed. +allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] +allLibModules lib clbi = + ordNub $ + explicitLibModules lib + ++ case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> map fst insts + _ -> [] + +-- ----------------------------------------------------------------------------- +-- Wrappers for a couple functions from InstallDirs + +-- | Backwards compatibility function which computes the InstallDirs +-- assuming that @$libname@ points to the public library (or some fake +-- package identifier if there is no public library.) IF AT ALL +-- POSSIBLE, please use 'absoluteComponentInstallDirs' instead. +absoluteInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg lbi copydest = + absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest + +-- | See 'InstallDirs.absoluteInstallDirs'. +absoluteComponentInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath +absoluteComponentInstallDirs + pkg + (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs}) + uid + copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + uid + (compilerInfo comp) + copydest + plat + installDirs + +absoluteInstallCommandDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath +absoluteInstallCommandDirs pkg lbi uid copydest = + dirs + { -- Handle files which are not + -- per-component (data files and Haddock files.) + datadir = datadir dirs' + , -- NB: The situation with Haddock is a bit delicate. On the + -- one hand, the easiest to understand Haddock documentation + -- path is pkgname-0.1, which means it's per-package (not + -- per-component). But this means that it's impossible to + -- install Haddock documentation for internal libraries. We'll + -- keep this constraint for now; this means you can't use + -- Cabal to Haddock internal libraries. This does not seem + -- like a big problem. + docdir = docdir dirs' + , htmldir = htmldir dirs' + , haddockdir = haddockdir dirs' + } + where + dirs = absoluteComponentInstallDirs pkg lbi uid copydest + -- Notice use of 'absoluteInstallDirs' (not the + -- per-component variant). This means for non-library + -- packages we'll just pick a nondescriptive foo-0.1 + dirs' = absoluteInstallDirs pkg lbi copydest + +-- | Backwards compatibility function which computes the InstallDirs +-- assuming that @$libname@ points to the public library (or some fake +-- package identifier if there is no public library.) IF AT ALL +-- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. +prefixRelativeInstallDirs + :: PackageId + -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) + +-- | See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeComponentInstallDirs + :: PackageId + -> LocalBuildInfo + -> UnitId + -> InstallDirs (Maybe FilePath) +prefixRelativeComponentInstallDirs + pkg_descr + (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs}) + uid = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + uid + (compilerInfo comp) + plat + installDirs + +substPathTemplate + :: PackageId + -> LocalBuildInfo + -> UnitId + -> PathTemplate + -> FilePath +substPathTemplate + pkgid + (LocalBuildInfo{compiler = comp, hostPlatform = plat}) + uid = + fromPathTemplate + . (InstallDirs.substPathTemplate env) + where + env = + initialPathTemplateEnv + pkgid + uid + (compilerInfo comp) + plat 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PackageIndex.hs @@ -0,0 +1,816 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages whose primary key is 'UnitId'. Public libraries +-- are additionally indexed by 'PackageName' and 'Version'. +-- Technically, these are an index of *units* (so we should eventually +-- rename it to 'UnitIndex'); but in the absence of internal libraries +-- or Backpack each unit is equivalent to a package. +-- +-- While 'PackageIndex' is parametric over what it actually records, +-- it is in fact only ever instantiated with a single element: +-- The 'InstalledPackageIndex' (defined here) contains a graph of +-- 'InstalledPackageInfo's representing the packages in a +-- package database stack. It is used in a variety of ways: +-- +-- * The primary use to let Cabal access the same installed +-- package database which is used by GHC during compilation. +-- For example, this data structure is used by 'ghc-pkg' +-- and 'Cabal' to do consistency checks on the database +-- (are the references closed). +-- +-- * Given a set of dependencies, we can compute the transitive +-- closure of dependencies. This is to check if the versions +-- of packages are consistent, and also needed by multiple +-- tools (Haddock must be explicitly told about the every +-- transitive package to do cross-package linking; +-- preprocessors must know about the include paths of all +-- transitive dependencies.) +-- +-- This 'PackageIndex' is NOT to be confused with +-- 'Distribution.Client.PackageIndex', which indexes packages only by +-- 'PackageName' (this makes it suitable for indexing source packages, +-- for which we don't know 'UnitId's.) +module Distribution.Simple.PackageIndex + ( -- * Package index data type + InstalledPackageIndex + , PackageIndex + + -- * Creating an index + , fromList + + -- * Updates + , merge + , insert + , deleteUnitId + , deleteSourcePackageId + , deletePackageName + -- deleteDependency, + + -- * Queries + + -- ** Precise lookups + , lookupUnitId + , lookupComponentId + , lookupSourcePackageId + , lookupPackageId + , lookupPackageName + , lookupInternalPackageName + , lookupDependency + , lookupInternalDependency + + -- ** Case-insensitive searches + , searchByName + , SearchResult (..) + , searchByNameSubstring + , searchWithPredicate + + -- ** Bulk queries + , allPackages + , allPackagesByName + , allPackagesBySourcePackageId + , allPackagesBySourcePackageIdAndLibName + + -- ** Special queries + , brokenPackages + , dependencyClosure + , reverseDependencyClosure + , topologicalOrder + , reverseTopologicalOrder + , dependencyInconsistencies + , dependencyCycles + , dependencyGraph + , moduleNameIndex + + -- ** Filters on lookup results + , eligibleDependencies + , matchingDependencies + ) where + +import qualified Data.Map.Strict as Map +import Distribution.Compat.Prelude hiding (lookup) +import Prelude () + +import Distribution.Backpack +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName +import Distribution.Package +import Distribution.Simple.Utils +import Distribution.Types.LibraryName +import Distribution.Version + +import Control.Exception (assert) +import Control.Monad +import Data.Array ((!)) +import qualified Data.Array as Array +import qualified Data.Graph as Graph +import Data.List as List (deleteBy, deleteFirstsBy, groupBy) +import qualified Data.List.NonEmpty as NE +import qualified Data.Tree as Tree +import Distribution.Compat.Stack + +import qualified Prelude (foldr1) + +-- | The collection of information about packages from one or more 'PackageDB's. +-- These packages generally should have an instance of 'PackageInstalled' +-- +-- Packages are uniquely identified in by their 'UnitId', they can +-- also be efficiently looked up by package name or by name and version. +data PackageIndex a = PackageIndex + { -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its UnitId. + -- + unitIdIndex :: !(Map UnitId a) + , -- This auxiliary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by UnitId + -- and are kept in preference order. + -- + -- FIXME: Clarify what "preference order" means. Check that this invariant is + -- preserved. See #1463 for discussion. + packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) + } + deriving (Eq, Generic, Show, Read) + +instance Binary a => Binary (PackageIndex a) +instance Structured a => Structured (PackageIndex a) + +-- | The default package index which contains 'InstalledPackageInfo'. Normally +-- use this. +type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo + +instance Monoid (PackageIndex IPI.InstalledPackageInfo) where + mempty = PackageIndex Map.empty Map.empty + mappend = (<>) + + -- save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = Prelude.foldr1 mappend xs + +instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where + (<>) = merge + +{-# NOINLINE invariant #-} +invariant :: WithCallStack (InstalledPackageIndex -> Bool) +invariant (PackageIndex pids pnames) = + -- trace (show pids' ++ "\n" ++ show pnames') $ + pids' == pnames' + where + pids' = map installedUnitId (Map.elems pids) + pnames' = + sort + [ assert pinstOk (installedUnitId pinst) + | ((pname, plib), pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedUnitId) pinsts + pinstsOk = + all + (\g -> length g == 1) + (groupBy (equating installedUnitId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = + packageName pinst == pname + && packageVersion pinst == pver + && IPI.sourceLibName pinst == plib + ] + +-- If you see this invariant failing (ie the assert in mkPackageIndex below) +-- then one thing to check is if it is happening in fromList. Check if the +-- second list above (the sort [...] bit) is ending up with duplicates. This +-- has been observed in practice once due to a messed up ghc-pkg db. How/why +-- it became messed up was not discovered. + +-- + +-- * Internal helpers + +-- + +mkPackageIndex + :: WithCallStack + ( Map UnitId IPI.InstalledPackageInfo + -> Map + (PackageName, LibraryName) + (Map Version [IPI.InstalledPackageInfo]) + -> InstalledPackageIndex + ) +mkPackageIndex pids pnames = assert (invariant index) index + where + index = PackageIndex pids pnames + +-- + +-- * Construction + +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates by 'UnitId' then later ones mask earlier +-- ones. +fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex +fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) + where + pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs] + pnames = + Map.fromList + [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) + | pkgsN <- + NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) + $ pkgs + , let pvers = + Map.fromList + [ ( packageVersion (NE.head pkgsNV) + , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV) + ) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN + ] + ] + +-- + +-- * Updates + +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages from the first if they have the exact +-- same 'UnitId'. +-- +-- For packages with the same source 'PackageId', packages from the second are +-- \"preferred\" over those from the first. Being preferred means they are top +-- result when we do a lookup by source 'PackageId'. This is the mechanism we +-- use to prefer user packages over global packages. +merge + :: InstalledPackageIndex + -> InstalledPackageIndex + -> InstalledPackageIndex +merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = + mkPackageIndex + (Map.unionWith (\_ y -> y) pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + where + -- Packages in the second list mask those in the first, however preferred + -- packages go first in the list. + mergeBuckets xs ys = ys ++ (xs \\ ys) + (\\) = deleteFirstsBy (equating installedUnitId) + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex +insert pkg (PackageIndex pids pnames) = + mkPackageIndex pids' pnames' + where + pids' = Map.insert (installedUnitId pkg) pkg pids + pnames' = insertPackageName pnames + insertPackageName = + Map.insertWith + (\_ -> insertPackageVersion) + (packageName pkg, IPI.sourceLibName pkg) + (Map.singleton (packageVersion pkg) [pkg]) + + insertPackageVersion = + Map.insertWith + (\_ -> insertPackageInstance) + (packageVersion pkg) + [pkg] + + insertPackageInstance pkgs = + pkg : deleteBy (equating installedUnitId) pkg pkgs + +-- | Removes a single installed package from the index. +deleteUnitId + :: UnitId + -> InstalledPackageIndex + -> InstalledPackageIndex +deleteUnitId ipkgid original@(PackageIndex pids pnames) = + case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of + (Nothing, _) -> original + (Just spkgid, pids') -> + mkPackageIndex + pids' + (deletePkgName spkgid pnames) + where + deletePkgName spkgid = + Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) + + deletePkgVersion spkgid = + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) + + deletePkgInstance = + (\xs -> if null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined + +-- | Removes all packages with this source 'PackageId' from the index. +deleteSourcePackageId + :: PackageId + -> InstalledPackageIndex + -> InstalledPackageIndex +deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = + -- NB: Doesn't delete internal packages + case Map.lookup (packageName pkgid, LMainLibName) pnames of + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> + mkPackageIndex + (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) + (deletePkgName pnames) + where + deletePkgName = + Map.update deletePkgVersion (packageName pkgid, LMainLibName) + + deletePkgVersion = + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +-- NB: Does NOT delete internal libraries from this package. +deletePackageName + :: PackageName + -> InstalledPackageIndex + -> InstalledPackageIndex +deletePackageName name original@(PackageIndex pids pnames) = + case Map.lookup (name, LMainLibName) pnames of + Nothing -> original + Just pvers -> + mkPackageIndex + ( foldl' + (flip (Map.delete . installedUnitId)) + pids + (concat (Map.elems pvers)) + ) + (Map.delete (name, LMainLibName) pnames) + +{- +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Dependency -> PackageIndex -> PackageIndex +deleteDependency (Dependency name verstionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-} + +-- + +-- * Bulk queries + +-- + +-- | Get all the packages from the index. +allPackages :: PackageIndex a -> [a] +allPackages = Map.elems . unitIdIndex + +-- | Get all the packages from the index. +-- +-- They are grouped by package name (case-sensitively). +-- +-- (Doesn't include private libraries.) +allPackagesByName :: PackageIndex a -> [(PackageName, [a])] +allPackagesByName index = + [ (pkgname, concat (Map.elems pvers)) + | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + ] + +-- | Get all the packages from the index. +-- +-- They are grouped by source package id (package name and version). +-- +-- (Doesn't include private libraries) +allPackagesBySourcePackageId + :: HasUnitId a + => PackageIndex a + -> [(PackageId, [a])] +allPackagesBySourcePackageId index = + [ (packageId ipkg, ipkgs) + | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + , ipkgs@(ipkg : _) <- Map.elems pvers + ] + +-- | Get all the packages from the index. +-- +-- They are grouped by source package id and library name. +-- +-- This DOES include internal libraries. +allPackagesBySourcePackageIdAndLibName + :: HasUnitId a + => PackageIndex a + -> [((PackageId, LibraryName), [a])] +allPackagesBySourcePackageIdAndLibName index = + [ ((packageId ipkg, ln), ipkgs) + | ((_, ln), pvers) <- Map.toList (packageIdIndex index) + , ipkgs@(ipkg : _) <- Map.elems pvers + ] + +-- + +-- * Lookups + +-- + +-- | Does a lookup by unit identifier. +-- +-- Since multiple package DBs mask each other by 'UnitId', +-- then we get back at most one package. +lookupUnitId + :: PackageIndex a + -> UnitId + -> Maybe a +lookupUnitId index uid = Map.lookup uid (unitIdIndex index) + +-- | Does a lookup by component identifier. In the absence +-- of Backpack, this is just a 'lookupUnitId'. +lookupComponentId + :: PackageIndex a + -> ComponentId + -> Maybe a +lookupComponentId index cid = + Map.lookup (newSimpleUnitId cid) (unitIdIndex index) + +-- | Does a lookup by source package id (name & version). +-- +-- There can be multiple installed packages with the same source 'PackageId' +-- but different 'UnitId'. They are returned in order of +-- preference, with the most preferred first. +lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] +lookupSourcePackageId index pkgid = + -- Do not lookup internal libraries + case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] + Just pkgs -> pkgs -- in preference order + +-- | Convenient alias of 'lookupSourcePackageId', but assuming only +-- one package per package ID. +lookupPackageId :: PackageIndex a -> PackageId -> Maybe a +lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of + [] -> Nothing + [pkg] -> Just pkg + _ -> error "Distribution.Simple.PackageIndex: multiple matches found" + +-- | Does a lookup by source package name. +lookupPackageName + :: PackageIndex a + -> PackageName + -> [(Version, [a])] +lookupPackageName index name = + -- Do not match internal libraries + lookupInternalPackageName index name LMainLibName + +-- | Does a lookup by source package name and library name. +-- +-- Also looks up internal packages. +lookupInternalPackageName + :: PackageIndex a + -> PackageName + -> LibraryName + -> [(Version, [a])] +lookupInternalPackageName index name library = + case Map.lookup (name, library) (packageIdIndex index) of + Nothing -> [] + Just pvers -> Map.toList pvers + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +-- This does NOT work for internal dependencies, DO NOT use this +-- function on those; use 'lookupInternalDependency' instead. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +lookupDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] +lookupDependency index pn vr = + -- Yes, a little bit of a misnomer here! + lookupInternalDependency index pn vr LMainLibName + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +lookupInternalDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> LibraryName + -> [(Version, [IPI.InstalledPackageInfo])] +lookupInternalDependency index name versionRange libn = + matchingDependencies versionRange $ + lookupInternalPackageName index name libn + +-- | Filter a set of installed packages to ones eligible as dependencies. +-- +-- When we select for dependencies, we ONLY want to pick up indefinite +-- packages, or packages with no instantiations. We'll do mix-in linking to +-- improve any such package into an instantiated one later. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +eligibleDependencies + :: [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +eligibleDependencies versions = + [ (ver, pkgs') + | (ver, pkgs) <- versions + , let pkgs' = filter eligible pkgs + , -- Enforce the invariant + not (null pkgs') + ] + where + eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) + +-- | Get eligible dependencies from a list of versions. +-- +-- This can be used to filter the output of 'lookupPackageName' or +-- 'lookupInternalPackageName'. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +matchingDependencies + :: VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +matchingDependencies versionRange versions = + let eligibleVersions = eligibleDependencies versions + in [ (ver, pkgs) + | (ver, pkgs) <- eligibleVersions + , ver `withinRange` versionRange + ] + +-- + +-- * Case insensitive name lookups + +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insensitively to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insensitively but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insensitively and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +searchByName :: PackageIndex a -> String -> SearchResult [a] +searchByName index name = + -- Don't match internal packages + case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname + ] of + [] -> None + [(_, pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of + Just (_, pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where + lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +searchByNameSubstring :: PackageIndex a -> String -> [a] +searchByNameSubstring index searchterm = + searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) + where + lsearchterm = lowercase searchterm + +-- | @since 3.4.0.0 +searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] +searchWithPredicate index predicate = + [ pkg + | -- Don't match internal packages + ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + , predicate (unPackageName pname) + , pkgs <- Map.elems pvers + , pkg <- pkgs + ] + +-- + +-- * Special queries + +-- + +-- None of the stuff below depends on the internal representation of the index. +-- + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] +dependencyCycles index = + [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList] + where + adjacencyList = + [ (pkg, installedUnitId pkg, installedDepends pkg) + | pkg <- allPackages index + ] + +-- | All packages that have immediate dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +brokenPackages + :: PackageInstalled a + => PackageIndex a + -> [(a, [UnitId])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = + [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg') + ] + , not (null missing) + ] + +-- | Tries to take the transitive closure of the package dependencies. +-- +-- If the transitive closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageId's do not occur in the index. +dependencyClosure + :: InstalledPackageIndex + -> [UnitId] + -> Either + (InstalledPackageIndex) + [(IPI.InstalledPackageInfo, [UnitId])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of + Nothing -> closure completed (pkgid : failed) pkgids + Just pkg -> case lookupUnitId completed (installedUnitId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where + completed' = insert pkg completed + pkgids' = installedDepends pkg ++ pkgids + +-- | Takes the transitive closure of the packages reverse dependencies. +-- +-- * The given 'PackageId's must be in the index. +reverseDependencyClosure + :: PackageInstalled a + => PackageIndex a + -> [UnitId] + -> [a] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] +topologicalOrder index = + map toPkgId + . Graph.topSort + $ graph + where + (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] +reverseTopologicalOrder index = + map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where + (graph, toPkgId, _) = dependencyGraph index + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +dependencyGraph + :: PackageInstalled a + => PackageIndex a + -> ( Graph.Graph + , Graph.Vertex -> a + , UnitId -> Maybe Graph.Vertex + ) +dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) + where + graph = + Array.listArray + bounds + [ [v | Just v <- map id_to_vertex (installedDepends pkg)] + | pkg <- pkgs + ] + + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedUnitId pkgs) [0 ..] + vertex_map = Map.fromList vertices + id_to_vertex pid = Map.lookup pid vertex_map + + vertex_to_pkg vertex = pkgTable ! vertex + + pkgTable = Array.listArray bounds pkgs + topBound = length pkgs - 1 + bounds = (0, topBound) + +-- | We maintain the invariant that, for any 'DepUniqueKey', there +-- is only one instance of the package in our database. +type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule) + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +dependencyInconsistencies + :: InstalledPackageIndex + -- At DepUniqueKey... + -> [ ( DepUniqueKey + , -- There were multiple packages (BAD!) + [ ( UnitId + , -- And here are the packages which + -- immediately depended on it + [IPI.InstalledPackageInfo] + ) + ] + ) + ] +dependencyInconsistencies index = do + (dep_key, insts_map) <- Map.toList inverseIndex + let insts = Map.toList insts_map + guard (length insts >= 2) + return (dep_key, insts) + where + inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) + inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do + pkg <- allPackages index + dep_ipid <- installedDepends pkg + Just dep <- [lookupUnitId index dep_ipid] + let dep_key = + ( packageName dep + , IPI.sourceLibName dep + , Map.fromList (IPI.instantiatedWith dep) + ) + return (dep_key, Map.singleton dep_ipid [pkg]) + +-- | A rough approximation of GHC's module finder, takes a +-- 'InstalledPackageIndex' and turns it into a map from module names to their +-- source packages. It's used to initialize the @build-deps@ field in @cabal +-- init@. +moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo] +moduleNameIndex index = + Map.fromListWith (++) $ do + pkg <- allPackages index + IPI.ExposedModule m reexport <- IPI.exposedModules pkg + case reexport of + Nothing -> return (m, [pkg]) + Just (OpenModuleVar _) -> [] + Just (OpenModule _ m') + | m == m' -> [] + | otherwise -> return (m', [pkg]) + +-- The heuristic is this: we want to prefer the original package +-- which originally exported a module. However, if a reexport +-- also *renamed* the module (m /= m'), then we have to use the +-- downstream package, since the upstream package has the wrong +-- module name! diff --git a/src/Distribution/Simple/PreProcess.hs b/src/Distribution/Simple/PreProcess.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PreProcess.hs @@ -0,0 +1,932 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines 'PPSuffixHandler', which is a combination of a file +-- extension and a function for configuring a 'PreProcessor'. It also defines +-- a bunch of known built-in preprocessors like @cpp@, @cpphs@, @c2hs@, +-- @hsc2hs@, @happy@, @alex@ etc and lists them in 'knownSuffixHandlers'. +-- On top of this it provides a function for actually preprocessing some sources +-- given a bunch of known suffix handlers. +-- This module is not as good as it could be, it could really do with a rewrite +-- to address some of the problems we have with pre-processors. +module Distribution.Simple.PreProcess + ( preprocessComponent + , preprocessExtras + , preprocessFile + , knownSuffixHandlers + , ppSuffixes + , PPSuffixHandler + , Suffix (..) + , builtinHaskellSuffixes + , builtinHaskellBootSuffixes + , PreProcessor (..) + , mkSimplePreProcessor + , runSimplePreProcessor + , ppCpp + , ppCpp' + , ppC2hs + , ppHsc2hs + , ppHappy + , ppAlex + , ppUnlit + , platformDefines + , unsorted + ) +where + +import Distribution.Compat.Prelude +import Distribution.Compat.Stack +import Prelude () + +import Distribution.Backpack.DescribeUnitId +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths +import Distribution.Simple.CCompiler +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.PreProcess.Unlit +import Distribution.Simple.Program +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.PackageName.Magic +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version + +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath + ( normalise + , replaceExtension + , splitExtension + , takeDirectory + , takeExtensions + ) +import System.Info (arch, os) + +-- | Just present the modules in the order given; this is the default and it is +-- appropriate for preprocessors which do not have any sort of dependencies +-- between modules. +unsorted + :: Verbosity + -> [path] + -> [ModuleName] + -> IO [ModuleName] +unsorted _ _ ms = pure ms + +-- | Function to determine paths to possible extra C sources for a +-- preprocessor: just takes the path to the build directory and uses +-- this to search for C sources with names that match the +-- preprocessor's output name format. +type PreProcessorExtras = + Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Source) + -> IO [RelativePath Source File] + +mkSimplePreProcessor + :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) + -> Verbosity + -> IO () +mkSimplePreProcessor + simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity = simplePP inFile outFile verbosity + where + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor + :: PreProcessor + -> FilePath + -> FilePath + -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- | A preprocessor for turning non-Haskell files with the given 'Suffix' +-- (i.e. file extension) into plain Haskell source files. +type PPSuffixHandler = + (Suffix, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +-- +-- XXX: This is terrible +preprocessComponent + :: PackageDescription + -> Component + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = + -- Skip preprocessing for scripts since they should be regular Haskell files, + -- but may have no or unknown extensions. + when (package pd /= fakePackageId) $ do + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' + verbosity + "Preprocessing" + (packageId pd) + (componentLocalName clbi) + (Nothing :: Maybe [(ModuleName, Module)]) + case comp of + (CLib lib@Library{libBuildInfo = bi}) -> do + let dirs = + hsSourceDirs bi + ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) + for_ (map moduleNameSymbolicPath mods) $ + pre dirs (componentBuildDir lbi clbi) hndlrs + (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do + let flibDir = flibBuildDir lbi flib + dirs = + hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) + for_ (map moduleNameSymbolicPath mods) $ + pre dirs flibDir hndlrs + (CExe exe@Executable{buildInfo = bi}) -> do + let exeDir = exeBuildDir lbi exe + dirs = + hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + for_ (map moduleNameSymbolicPath mods) $ + pre dirs exeDir hndlrs + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensionsSymbolicPath (modulePath exe) + CTest test@TestSuite{} -> do + let testDir = testBuildDir lbi test + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f testDir + TestSuiteLibV09 _ _ -> do + writeSimpleTestStub test (i testDir) + preProcessTest test (makeRelativePathEx $ stubFilePath test) testDir + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportForPreProcessingTest tt + CBench bm@Benchmark{} -> do + let benchDir = benchmarkBuildDir lbi bm + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f benchDir + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt + where + orderingFromHandlers v d hndlrs mods = + foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs + builtinCSuffixes = map Suffix cSourceExtensions + builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes + localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + pre dirs dir lhndlrs fp = + preprocessFile mbWorkDir dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs True + preProcessTest test = + preProcessComponent + (testBuildInfo test) + (testModules test) + preProcessBench bm = + preProcessComponent + (benchmarkBuildInfo bm) + (benchmarkModules bm) + + preProcessComponent + :: BuildInfo + -> [ModuleName] + -> RelativePath Source File + -> SymbolicPath Pkg (Dir Build) + -> IO () + preProcessComponent bi modules exePath outputDir = do + let biHandlers = localHandlers bi + sourceDirs = + hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + sequence_ + [ preprocessFile + mbWorkDir + sourceDirs + outputDir + isSrcDist + (moduleNameSymbolicPath modu) + verbosity + builtinSuffixes + biHandlers + False + | modu <- modules + ] + -- Note we don't fail on missing in this case, because the main file + -- may be generated later (i.e. by a test code generator) + preprocessFile + mbWorkDir + (coerceSymbolicPath outputDir : hsSourceDirs bi) + outputDir + isSrcDist + (dropExtensionsSymbolicPath $ exePath) + verbosity + builtinSuffixes + biHandlers + False + +-- TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- | Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ package directory location + -> [SymbolicPath Pkg (Dir Source)] + -- ^ source directories + -> SymbolicPath Pkg (Dir Build) + -- ^ build directory + -> Bool + -- ^ preprocess for sdist + -> RelativePath Source File + -- ^ module file name + -> Verbosity + -- ^ verbosity + -> [Suffix] + -- ^ builtin suffixes + -> [(Suffix, PreProcessor)] + -- ^ possible preprocessors + -> Bool + -- ^ fail on missing file + -> IO () +preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + + -- Note [Dodgy build dirs for preprocessors] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- By looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (buildAsSrcLoc : searchLoc) baseFile + case (bsrcFiles, failOnMissing) of + (Nothing, True) -> + dieWithException verbosity $ + CantFindSourceForPreProcessFile $ + "can't find source for " + ++ getSymbolicPath baseFile + ++ " in " + ++ intercalate ", " (map getSymbolicPath searchLoc) + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = + fromMaybe + (error "Distribution.Simple.PreProcess: Just expected") + (lookup (Suffix $ safeTail ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + -- TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> + i psrcFile `moreRecentFile` i ppsrcFile + when recomp $ do + let destDir = i buildLoc takeDirectory srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack + pp + (psrcLoc, getSymbolicPath $ psrcRelFile) + (buildLoc, srcStem <.> "hs") + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + buildAsSrcLoc :: SymbolicPath Pkg (Dir Source) + buildAsSrcLoc = coerceSymbolicPath buildLoc + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack + pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + -- Preprocessors are expected to take into account the working + -- directory, e.g. using runProgramCwd with a working directory + -- computed with mbWorkDirLBI. + -- Hence the use of 'getSymbolicPath' here. + runPreProcessor + pp + (getSymbolicPath $ inBaseDir, inRelativeFile) + (getSymbolicPath $ outBaseDir, outRelativeFile) + verbosity + + -- Here we interact directly with the file system, so we must + -- interpret symbolic paths with respect to the working directory. + let + inFile = normalise (i inBaseDir inRelativeFile) + outFile = normalise (i outBaseDir outRelativeFile) + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + +-- ------------------------------------------------------------ + +-- * known preprocessors + +-- ------------------------------------------------------------ + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor + { platformIndependent = True + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) (dieWithException verbosity) (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi clbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi + GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi + _ -> ppCpphs args bi lbi clbi + where + cppArgs = getCppOptions bi lbi + args = cppArgs ++ extraArgs + +ppGhcCpp + :: Program + -> (Version -> Bool) + -> [String] + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> PreProcessor +ppGhcCpp program xHs extraArgs _bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (prog, version, _) <- + requireProgramVersion + verbosity + program + anyVersion + (withPrograms lbi) + runProgramCwd verbosity (mbWorkDirLBI lbi) prog $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if xHs version then ["-x", "hs"] else []) + ++ ["-optP-include", "-optP" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- + requireProgramVersion + verbosity + cpphsProgram + anyVersion + (withPrograms lbi) + runProgramCwd verbosity (mbWorkDirLBI lbi) cpphsProg $ + ("-O" ++ outFile) + : inFile + : "--noline" + : "--strip" + : ( if cpphsVersion >= mkVersion [1, 6] + then ["--include=" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + else [] + ) + ++ extraArgs + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + (hsc2hsProg, hsc2hsVersion, _) <- + requireProgramVersion + verbosity + hsc2hsProgram + anyVersion + (withPrograms lbi) + let runHsc2hs = runProgramCwd verbosity mbWorkDir hsc2hsProg + -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. + let isCross = hostPlatform lbi /= buildPlatform + prependCrossFlags = if isCross then ("-x" :) else id + let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0, 68, 4] + pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile + if hsc2hsSupportsResponseFiles + then + withResponseFile + verbosity + defaultTempFileOptions + "hsc2hs-response.txt" + Nothing + pureArgs + ( \responseFileName -> + runHsc2hs (prependCrossFlags ["@" ++ responseFileName]) + ) + else runHsc2hs (prependCrossFlags pureArgs) + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPathX allowAbs Pkg to -> FilePath + u = interpretSymbolicPathCWD + mbWorkDir = mbWorkDirLBI lbi + + -- Returns a list of command line arguments that can either be passed + -- directly, or via a response file. + genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String] + genPureArgs hsc2hsVersion gccProg inFile outFile = + -- Additional gcc options + [ "--cflag=" ++ opt + | opt <- + programDefaultArgs gccProg + ++ programOverrideArgs gccProg + ] + ++ [ "--lflag=" ++ opt + | opt <- + programDefaultArgs gccProg + ++ programOverrideArgs gccProg + ] + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] + ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- map getSymbolicPath (PD.frameworks bi) ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] + ] + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ ["--cflag=" ++ opt | opt <- platformDefines lbi] + -- Options from the current package: + ++ ["--cflag=-I" ++ u dir | dir <- PD.includeDirs bi] + ++ [ "--cflag=-I" ++ u (buildDir lbi unsafeCoerceSymbolicPath relDir) + | relDir <- mapMaybe symbolicPathRelative_maybe $ PD.includeDirs bi + ] + ++ [ "--cflag=" ++ opt + | opt <- + PD.ccOptions bi + ++ PD.cppOptions bi + -- hsc2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- DO NOT add PD.cxxOptions unless this changes! + ] + ++ [ "--cflag=" ++ opt + | opt <- + [ "-I" ++ u (autogenComponentModulesDir lbi clbi) + , "-I" ++ u (autogenPackageModulesDir lbi) + , "-include" + , u $ autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName + ] + ] + ++ [ "--lflag=-L" ++ u opt + | opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ [ "--lflag=-Wl,-R," ++ u opt + | isELF + , opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ ["--lflag=-l" ++ opt | opt <- PD.extraLibs bi] + ++ ["--lflag=" ++ opt | opt <- PD.ldOptions bi] + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ Installed.ccOptions pkg + ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- + ["-L" ++ opt | opt <- Installed.libraryDirs pkg] + ++ [ "-Wl,-R," ++ opt | isELF, opt <- Installed.libraryDirs pkg + ] + ++ [ "-l" ++ opt + | opt <- + if withFullyStaticExe lbi + then Installed.extraLibrariesStatic pkg + else Installed.extraLibraries pkg + ] + ++ Installed.ldOptions pkg + ] + ++ preccldFlags + ++ hsc2hsOptions bi + ++ postccldFlags + ++ ["-o", outFile, inFile] + where + -- hsc2hs flag parsing was wrong + -- (see -- https://github.com/haskell/hsc2hs/issues/35) + -- so we need to put -- --cc/--ld *after* hsc2hsOptions, + -- for older hsc2hs (pre 0.68.8) so that they can be overridden. + ccldFlags = + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg + ] + + (preccldFlags, postccldFlags) + | hsc2hsVersion >= mkVersion [0, 68, 8] = (ccldFlags, []) + | otherwise = ([], ccldFlags) + + hacked_index = packageHacks (installedPkgs lbi) + -- Look only at the dependencies of the current component + -- being built! This relies on 'installedPkgs' maintaining + -- 'InstalledPackageInfo' for internal deps too; see #2971. + pkgs = PackageIndex.topologicalOrder $ + case PackageIndex.dependencyClosure + hacked_index + (map fst (componentPackageDeps clbi)) of + Left index' -> index' + Right inf -> + error ("ppHsc2hs: broken closure: " ++ show inf) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + GHCJS -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] -> + PackageIndex.insert rts{Installed.ldOptions = []} index + _ -> error "No (or multiple) ghc rts package is registered!!" + +ppHsc2hsExtras :: PreProcessorExtras +ppHsc2hsExtras mbWorkDir buildBaseDir = do + fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir + let hscCFiles = filter ("_hsc.c" `isSuffixOf`) fs + return $ map makeRelativePathEx hscCFiles + +ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppC2hs bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = + \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity -> do + (c2hsProg, _, _) <- + requireProgramVersion + verbosity + c2hsProgram + (orLaterVersion (mkVersion [0, 15])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + runProgramCwd verbosity mbWorkDir c2hsProg $ + -- Options from the current package: + ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--cppopts=-include" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + ++ ["--include=" ++ outBaseDir] + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg, + -- c2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- + -- DO NOT add Installed.cxxOptions unless this changes! + c `elem` "DIU" + ] + ] + -- TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile + ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + mbWorkDir = mbWorkDirLBI lbi + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + +ppC2hsExtras :: PreProcessorExtras +ppC2hsExtras mbWorkDir buildBaseDir = do + fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir + return $ + map makeRelativePathEx $ + filter (\p -> takeExtensions p == ".chs.c") fs + +-- TODO: perhaps use this with hsc2hs too +-- TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +-- TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC +-- instead of combining all these cases in a single function. This blind combination can +-- potentially lead to compilation inconsistencies. +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi = + platformDefines lbi + ++ cppOptions bi + ++ ["-I" ++ getSymbolicPath dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] + +platformDefines :: LocalBuildInfo -> [String] +platformDefines lbi = + case compilerFlavor comp of + GHC -> + ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + GHCJS -> + compatGlasgowHaskell + ++ ["-D__GHCJS__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + _ -> [] + where + comp = compiler lbi + Platform hostArch hostOS = hostPlatform lbi + version = compilerVersion comp + compatGlasgowHaskell = + maybe + [] + (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) + (compilerCompatVersion GHC comp) + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt v = case versionNumbers v of + [] -> "1" + [n] -> show n + n1 : n2 : _ -> + -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + + osStr = case hostOS of + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] + DragonFly -> ["dragonfly"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + IOS -> ["ios"] + Android -> ["android"] + Ghcjs -> ["ghcjs"] + Wasi -> ["wasi"] + Hurd -> ["hurd"] + Haiku -> ["haiku"] + OtherOS _ -> [] + archStr = case hostArch of + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + PPC64LE -> ["powerpc64le"] + Sparc -> ["sparc"] + Sparc64 -> ["sparc64"] + Arm -> ["arm"] + AArch64 -> ["aarch64"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + S390X -> ["s390x"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + RISCV64 -> ["riscv64"] + LoongArch64 -> ["loongarch64"] + JavaScript -> ["javascript"] + Wasm32 -> ["wasm32"] + OtherArch _ -> [] + +ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHappy _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags GHCJS = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppAlex _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags GHCJS = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgramCwd + verbosity + (mbWorkDirLBI lbi) + prog + (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- | Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [PPSuffixHandler] -> [Suffix] +ppSuffixes = map fst + +-- | Standard preprocessors: c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [PPSuffixHandler] +knownSuffixHandlers = + [ (Suffix "chs", ppC2hs) + , (Suffix "hsc", ppHsc2hs) + , (Suffix "x", ppAlex) + , (Suffix "y", ppHappy) + , (Suffix "ly", ppHappy) + , (Suffix "cpphs", ppCpp) + ] + +-- | Standard preprocessors with possible extra C sources: c2hs, hsc2hs. +knownExtrasHandlers :: [PreProcessorExtras] +knownExtrasHandlers = [ppC2hsExtras, ppHsc2hsExtras] + +-- | Find any extra C sources generated by preprocessing that need to +-- be added to the component (addresses issue #238). +preprocessExtras + :: Verbosity + -> Component + -> LocalBuildInfo + -> IO [SymbolicPath Pkg File] +preprocessExtras verbosity comp lbi = case comp of + CLib _ -> pp $ buildDir lbi + (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe + (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib + CTest test -> + case testInterface test of + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingTestExtras tt + _ -> pp $ testBuildDir lbi test + CBench bm -> + case benchmarkInterface bm of + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt + _ -> pp $ benchmarkBuildDir lbi bm + where + pp :: SymbolicPath Pkg (Dir Build) -> IO [SymbolicPath Pkg File] + pp builddir = do + -- Use the build dir as a source dir. + let dir :: SymbolicPath Pkg (Dir Source) + dir = coerceSymbolicPath builddir + mbWorkDir = mbWorkDirLBI lbi + b <- doesDirectoryExist (interpretSymbolicPathLBI lbi dir) + if b + then do + xs <- for knownExtrasHandlers $ withLexicalCallStack $ \f -> f mbWorkDir dir + let not_subs = + map (dir ) $ + filter (not_sub . getSymbolicPath) $ + concat xs + return not_subs + else pure [] + -- TODO: This is a terrible hack to work around #3545 while we don't + -- reorganize the directory layout. Basically, for the main + -- library, we might accidentally pick up autogenerated sources for + -- our subcomponents, because they are all stored as subdirectories + -- in dist/build. This is a cheap and cheerful check to prevent + -- this from happening. It is not particularly correct; for example + -- if a user has a test suite named foobar and puts their C file in + -- foobar/foo.c, this test will incorrectly exclude it. But I + -- didn't want to break BC... + not_sub p = and [not (pre `isPrefixOf` p) | pre <- component_dirs] + component_dirs = component_names (localPkgDescr lbi) + -- TODO: libify me + component_names pkg_descr = + fmap unUnqualComponentName $ + mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) + ++ map exeName (executables pkg_descr) + ++ map testName (testSuites pkg_descr) + ++ map benchmarkName (benchmarks pkg_descr) 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PreProcess/Unlit.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" +module Distribution.Simple.PreProcess.Unlit (unlit, plain) where + +import Data.List (mapAccumL) +import Distribution.Compat.Prelude +import Distribution.Simple.Errors +import Distribution.Utils.Generic (safeInit, safeLast, safeTail) +import Prelude () + +data Classified + = BirdTrack String + | Blank String + | Ordinary String + | Line !Int String + | CPP String + | BeginCode + | EndCode + | -- output only: + Error String + | Comment String + +-- | No unliteration. +plain :: String -> String -> String +plain _ hs = hs + +classify :: String -> Classified +classify ('>' : s) = BirdTrack s +classify ('#' : s) = case tokens s of + (line : file@('"' : _ : _) : _) + | all isDigit line + && safeLast file == Just '"' -> + -- this shouldn't fail as we tested for 'all isDigit' + Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse + _ -> CPP s + where + tokens = unfoldr $ \str -> case lex str of + (t@(_ : _), str') : _ -> Just (t, str') + _ -> Nothing +classify ('\\' : s) + | "begin{code}" `isPrefixOf` s = BeginCode + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s + +-- So the weird exception for comment indenting is to make things work with +-- haddock, see classifyAndCheckForBirdTracks below. +unclassify :: Bool -> Classified -> String +unclassify _ (BirdTrack s) = ' ' : s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#' : s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError + +-- | 'unlit' takes a filename (for error reports), and transforms the +-- given string, to eliminate the literate comments from the program text. +unlit :: FilePath -> String -> Either String CabalException +unlit file input = + let (usesBirdTracks, classified) = + classifyAndCheckForBirdTracks + . inlines + $ input + in either + (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified + where + -- So haddock requires comments and code to align, since it treats comments + -- as following the layout rule. This is a pain for us since bird track + -- style literate code typically gets indented by two since ">" is replaced + -- by " " and people usually use one additional space of indent ie + -- "> then the code". On the other hand we cannot just go and indent all + -- the comments by two since that does not work for latex style literate + -- code. So the hacky solution we use here is that if we see any bird track + -- style code then we'll indent all comments by two, otherwise by none. + -- Of course this will not work for mixed latex/bird track .lhs files but + -- nobody does that, it's silly and specifically recommended against in the + -- H98 unlit spec. + -- + classifyAndCheckForBirdTracks = + flip mapAccumL False $ \seenBirdTrack line -> + let classification = classify line + in (seenBirdTrack || isBirdTrack classification, classification) + + isBirdTrack (BirdTrack _) = True + isBirdTrack _ = False + + checkErrors ls = case [e | Error e <- ls] of + [] -> Left ls + (message : _) -> Right (UnlitException (f ++ ":" ++ show n ++ ": " ++ message)) + where + (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _ : _) = (f, n) + errorPos _ _ (Line n' f' : ls) = errorPos f' n' ls + errorPos f n (_ : ls) = errorPos f (n + 1) ls + +-- Here we model a state machine, with each state represented by +-- a local function. We only have four states (well, five, +-- if you count the error state), but the rules +-- to transition between then are not so simple. +-- Would it be simpler to have more states? +-- +-- Each state represents the type of line that was last read +-- i.e. are we in a comment section, or a latex-code section, +-- or a bird-code section, etc? +reclassify :: [Classified] -> [Classified] +reclassify = blank -- begin in blank state + where + latex [] = [] + latex (EndCode : ls) = Blank "" : comment ls + latex (BeginCode : _) = [Error "\\begin{code} in code section"] + latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls + latex (l : ls) = l : latex ls + + blank [] = [] + blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode : ls) = Blank "" : latex ls + blank (BirdTrack l : ls) = BirdTrack l : bird ls + blank (Ordinary l : ls) = Comment l : comment ls + blank (l : ls) = l : blank ls + + bird [] = [] + bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode : ls) = Blank "" : latex ls + bird (Blank l : ls) = Blank l : blank ls + bird (Ordinary _ : _) = [Error "program line before comment line"] + bird (l : ls) = l : bird ls + + comment [] = [] + comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode : ls) = Blank "" : latex ls + comment (CPP l : ls) = CPP l : comment ls + comment (BirdTrack _ : _) = [Error "comment line before program line"] + -- a blank line and another ordinary line following a comment + -- will be treated as continuing the comment. Otherwise it's + -- then end of the comment, with a blank line. + comment (Blank l : ls@(Ordinary _ : _)) = Comment l : comment ls + comment (Blank l : ls) = Blank l : blank ls + comment (Line n f : ls) = Line n f : comment ls + comment (Ordinary l : ls) = Comment l : comment ls + comment (Comment _ : _) = internalError + comment (Error _ : _) = internalError + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines :: String -> [String] +inlines xs = lines' xs id + where + lines' [] acc = [acc []] + lines' ('\^M' : '\n' : s) acc = acc [] : lines' s id -- DOS + lines' ('\^M' : s) acc = acc [] : lines' s id -- MacOS + lines' ('\n' : s) acc = acc [] : lines' s id -- Unix + lines' (c : s) acc = lines' s (acc . (c :)) + +internalError :: a +internalError = error "unlit: internal error" diff --git a/src/Distribution/Simple/Program.hs b/src/Distribution/Simple/Program.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program.hs @@ -0,0 +1,251 @@ +{- FUTUREWORK: + - + - Currently the logic in this module is not tested. + - + - Ideally, a set of unit tests that check whether certain + - flags trigger recompilation should be added. + - -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramDb' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramDb' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramDb' which contains them all. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. +module Distribution.Simple.Program + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) + , simpleProgram + , findProgramOnSearchPath + , defaultProgramSearchPath + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram (..) + , programPath + , ProgArg + , ProgramLocation (..) + , runProgram + , runProgramCwd + , getProgramOutput + , suppressOverrideArgs + + -- * Program invocations + , ProgramInvocation (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS + + -- * The collection of unconfigured and configured programs + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramDb + , defaultProgramDb + , emptyProgramDb + , restoreProgramDb + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramVersion + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + , runDbProgram + , runDbProgramCwd + , getDbProgramOutput + , getDbProgramOutputCwd + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , jhcProgram + , uhcProgram + , gccProgram + , gppProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Errors +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Verbosity + +-- | Runs the given configured program. +runProgram + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runProgram verbosity prog args = + runProgramInvocation verbosity (programInvocation prog args) + +-- | Runs the given configured program. +runProgramCwd + :: Verbosity + -- ^ Verbosity + -> Maybe (SymbolicPath CWD (Dir to)) + -- ^ Working directory + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runProgramCwd verbosity mbWorkDir prog args = + runProgramInvocation verbosity (programInvocationCwd mbWorkDir prog args) + +-- | Runs the given configured program and gets the output. +getProgramOutput + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String +getProgramOutput verbosity prog args = + getProgramInvocationOutput verbosity (programInvocation prog args) + +-- | Looks up the given program in the program database and runs it. +runDbProgram + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog progDb args = + runDbProgramCwd verbosity Nothing prog progDb args + +-- | Looks up the given program in the program database and runs it. +runDbProgramCwd + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir to)) + -- ^ working directory + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runDbProgramCwd verbosity mbWorkDir prog programDb args = + case lookupProgram prog programDb of + Nothing -> + dieWithException verbosity $ ProgramNotFound (programName prog) + Just configuredProg -> runProgramCwd verbosity mbWorkDir configuredProg args + +-- | Looks up the given program in the program database and runs it. +getDbProgramOutput + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String +getDbProgramOutput verb prog progDb args = + getDbProgramOutputCwd verb Nothing prog progDb args + +-- | Looks up the given program in the program database and runs it. +getDbProgramOutputCwd + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir to)) + -- ^ working directory + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String +getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = + case lookupProgram prog programDb of + Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog) + Just configuredProg -> + getProgramInvocationOutput verbosity $ + programInvocationCwd mbWorkDir configuredProg args diff --git a/src/Distribution/Simple/Program/Ar.hs b/src/Distribution/Simple/Program/Ar.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Ar.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Ar +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ar@ program. +module Distribution.Simple.Program.Ar + ( createArLibArchive + , multiStageProgramInvocation + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Distribution.Compat.CopyFile (filesEqual) +import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) +import Distribution.Simple.Program + ( ProgramInvocation + , arProgram + , requireProgram + ) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile + ) +import Distribution.Simple.Program.Run + ( multiStageProgramInvocation + , programInvocationCwd + , runProgramInvocation + ) +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config + ( configUseResponseFiles + ) +import Distribution.Simple.Utils + ( defaultTempFileOptions + , dieWithLocation' + , withTempDirectoryCwd + ) +import Distribution.System + ( Arch (..) + , OS (..) + , Platform (..) + ) +import Distribution.Utils.Path +import Distribution.Verbosity + ( Verbosity + , deafening + , verbose + ) + +import System.Directory (doesFileExist, renameFile) +import System.FilePath (splitFileName) +import System.IO + ( Handle + , IOMode (ReadWriteMode) + , SeekMode (AbsoluteSeek) + , hFileSize + , hSeek + , withBinaryFile + ) + +-- | Call @ar@ to create a library archive from a bunch of object files. +createArLibArchive + :: Verbosity + -> LocalBuildInfo + -> SymbolicPath Pkg File + -> [SymbolicPath Pkg File] + -> IO () +createArLibArchive verbosity lbi targetPath files = do + (arProg, _) <- requireProgram verbosity arProgram progDb + + let (targetDir0, targetName0) = splitFileName $ getSymbolicPath targetPath + targetDir = makeSymbolicPath targetDir0 + targetName = makeRelativePathEx targetName0 + mbWorkDir = mbWorkDirLBI lbi + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPath mbWorkDir + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do + let tmpPath = tmpDir targetName + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier + -- in "q" mode which compels the archiver to add the members of an input + -- archive to the output, rather than the archive itself. This is + -- necessary as GHC may produce .o files that are actually archives. See + -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. + + let simpleArgs, initialArgs, finalArgs :: [String] + simpleArgs = case hostOS of + OSX -> ["-r", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case hostOS of + OSX -> ["-q", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [u tmpPath] + + ar = programInvocationCwd mbWorkDir arProg + simple = ar (simpleArgs ++ extraArgs) + initial = ar (initialArgs ++ extraArgs) + middle = initial + final = ar (finalArgs ++ extraArgs) + + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + dashLSupported = + arDashLSupported (compiler lbi) + + invokeWithResponseFile :: FilePath -> ProgramInvocation + invokeWithResponseFile atFile = + (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile]) + + if oldVersionManualOverride || responseArgumentsNotSupported + then + sequence_ + [ runProgramInvocation verbosity inv + | inv <- + multiStageProgramInvocation + simple + (initial, middle, final) + (map getSymbolicPath files) + ] + else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ + \path -> runProgramInvocation verbosity $ invokeWithResponseFile path + + unless + ( hostArch == Arm -- See #1537 + || hostOS == AIX + ) + $ wipeMetadata verbosity (i tmpPath) -- AIX uses its own "ar" format variant + equal <- filesEqual (i tmpPath) (i targetPath) + unless equal $ renameFile (i tmpPath) (i targetPath) + where + progDb = withPrograms lbi + Platform hostArch hostOS = hostPlatform lbi + verbosityOpts v + | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] -- Do not warn if library had to be created. + +-- | @ar@ by default includes various metadata for each object file in their +-- respective headers, so the output can differ for the same inputs, making +-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode +-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 +-- for the file mode. However detecting whether @-D@ is supported seems +-- rather harder than just re-implementing this feature. +wipeMetadata :: Verbosity -> FilePath -> IO () +wipeMetadata verbosity path = do + -- Check for existence first (ReadWriteMode would create one otherwise) + exists <- doesFileExist path + unless exists $ wipeError "Temporary file disappeared" + withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h + where + wipeError msg = + dieWithLocation' verbosity path Nothing $ + "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg + archLF = "!\x0a" -- global magic, 8 bytes + x60LF = "\x60\x0a" -- header magic, 2 bytes + metadata = + BS.concat + [ "0 " -- mtime, 12 bytes + , "0 " -- UID, 6 bytes + , "0 " -- GID, 6 bytes + , "0644 " -- mode, 8 bytes + ] + headerSize :: Int + headerSize = 60 + + -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details + wipeArchive :: Handle -> Integer -> IO () + wipeArchive h archiveSize = do + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ wipeError "Bad global header" + wipeHeader (toInteger $ BS.length archLF) + where + wipeHeader :: Integer -> IO () + wipeHeader offset = case compare offset archiveSize of + EQ -> return () + GT -> wipeError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + wipeError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . wipeError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + let name = BS.take 16 header + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> wipeError (atOffset "Bad file size in header") + + let replacement = BS.concat [name, metadata, size, magic] + unless (BS.length replacement == headerSize) $ + wipeError (atOffset "Something has gone terribly wrong") + hSeek h AbsoluteSeek offset + BS.hPut h replacement + + let nextHeader = + offset + + toInteger headerSize + + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + wipeHeader nextHeader + where + atOffset msg = msg ++ " at offset " ++ show offset diff --git a/src/Distribution/Simple/Program/Builtin.hs b/src/Distribution/Simple/Program/Builtin.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Builtin.hs @@ -0,0 +1,386 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Builtin +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The module defines all the known built-in 'Program's. +-- +-- Where possible we try to find their version numbers. +module Distribution.Simple.Program.Builtin + ( -- * The collection of unconfigured and configured programs + builtinPrograms + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , runghcProgram + , ghcjsProgram + , ghcjsPkgProgram + , jhcProgram + , uhcProgram + , gccProgram + , gppProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program.Internal +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Version + +import qualified Data.Map as Map + +-- ------------------------------------------------------------ + +-- * Known programs + +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ -- compilers and related progs + ghcProgram + , runghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , jhcProgram + , uhcProgram + , hpcProgram + , -- preprocessors + hscolourProgram + , doctestProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , -- platform toolchain + gccProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + , -- configuration tools + pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = + (simpleProgram "ghc") + { programFindVersion = findProgramVersion "--numeric-version" id + , programPostConf = ghcPostConf + , programNormaliseArgs = normaliseGhcArgs + } + where + ghcPostConf _verbosity ghcProg = do + let setLanguageEnv prog = + prog + { programOverrideEnv = + ("LANGUAGE", Just "en") + : programOverrideEnv ghcProg + } + + ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} + + -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. + affectedVersionRange = + intersectVersionRanges + (laterVersion $ mkVersion [7, 8, 0]) + (earlierVersion $ mkVersion [7, 8, 4]) + + canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4] + + applyWhen cond f prog = if cond then f prog else prog + + return $ + maybe + ghcProg + ( \v -> + -- By default, ignore GHC_ENVIRONMENT variable of any package environmnet + -- files. See #10759 + applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv + -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 + -- (spurious warning on non-english locales) + $ + applyWhen (withinRange v affectedVersionRange) setLanguageEnv $ + ghcProg + ) + (programVersion ghcProg) + +runghcProgram :: Program +runghcProgram = + (simpleProgram "runghc") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "runghc 7.10.3" + (_ : ver : _) -> ver + _ -> "" + } + +ghcPkgProgram :: Program +ghcPkgProgram = + (simpleProgram "ghc-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } + +ghcjsProgram :: Program +ghcjsProgram = + (simpleProgram "ghcjs") + { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id + } + +-- note: version is the version number of the GHC version that ghcjs-pkg was built with +ghcjsPkgProgram :: Program +ghcjsPkgProgram = + (simpleProgram "ghcjs-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghcjs-pkg --version" gives a string like + -- "GHCJS package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = + (simpleProgram "jhc") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_ : ver : _) -> ver + _ -> "" + } + +uhcProgram :: Program +uhcProgram = + (simpleProgram "uhc") + { programFindVersion = findProgramVersion "--version-dotted" id + } + +hpcProgram :: Program +hpcProgram = + (simpleProgram "hpc") + { programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" + } + +happyProgram :: Program +happyProgram = + (simpleProgram "happy") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = + (simpleProgram "alex") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_ : _ : ver : _) -> takeWhile (\x -> isDigit x || x == '.') ver + _ -> "" + } + +gccProgram :: Program +gccProgram = + (simpleProgram "gcc") + { programFindVersion = findProgramVersion "-dumpversion" id + } + +gppProgram :: Program +gppProgram = + (simpleProgram "gpp") + { programFindVersion = findProgramVersion "-dumpversion" id + , programFindLocation = \v p -> findProgramOnSearchPath v p "g++" + } + +arProgram :: Program +arProgram = simpleProgram "ar" + +stripProgram :: Program +stripProgram = + (simpleProgram "strip") + { programFindVersion = \verbosity -> + findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + } + +hsc2hsProgram :: Program +hsc2hsProgram = + (simpleProgram "hsc2hs") + { programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } + +c2hsProgram :: Program +c2hsProgram = + (simpleProgram "c2hs") + { programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = + (simpleProgram "cpphs") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_ : ver : _) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = + (simpleProgram "hscolour") + { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour" + , programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_ : ver : _) -> ver + _ -> "" + } + +-- TODO: Ensure that doctest is built against the same GHC as the one +-- that's being used. Same for haddock. @phadej pointed this out. +doctestProgram :: Program +doctestProgram = + (simpleProgram "doctest") + { programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" + , programFindVersion = findProgramVersion "--version" $ \str -> + -- "doctest version 0.11.2" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = + (simpleProgram "haddock") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_ : _ : ver : _) -> takeWhile (`elem` ('.' : ['0' .. '9'])) ver + _ -> "" + , programNormaliseArgs = \_ _ args -> args + } + +ldProgram :: Program +ldProgram = + (simpleProgram "ld") + { programPostConf = \verbosity ldProg -> do + -- The `lld` linker cannot create merge (relocatable) objects so we + -- want to detect this. + -- If the linker does support relocatable objects, we want to use that + -- to create partially pre-linked objects for GHCi, so we get much + -- faster loading as we do not have to do the separate loading and + -- in-memory linking the static linker in GHC does, but can offload + -- parts of this process to a pre-linking step. + -- However this requires the linker to support this features. Not all + -- linkers do, and notably as of this writing `lld` which is a popular + -- choice for windows linking does not support this feature. However + -- if using binutils ld or another linker that supports --relocatable, + -- we should still be good to generate pre-linked objects. + ldHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation ldProg ["--help"]) + -- In case the linker does not support '--help'. Eg the LLVM linker, + -- `lld` only accepts `-help`. + `catchIO` (\_ -> return "") + let k = "Supports relocatable output" + -- Standard GNU `ld` uses `--relocatable` while `ld.gold` uses + -- `-relocatable` (single `-`). + v + | "-relocatable" `isInfixOf` ldHelpOutput = "YES" + -- ld64 on macOS has this lovely response for "--help" + -- + -- ld64: For information on command line options please use 'man ld'. + -- + -- it does however support -r, if you read the manpage + -- (e.g. https://www.manpagez.com/man/1/ld64/) + | "ld64:" `isPrefixOf` ldHelpOutput = "YES" + | otherwise = "NO" + + m = Map.insert k v (programProperties ldProg) + return $ ldProg{programProperties = m} + } + +tarProgram :: Program +tarProgram = + (simpleProgram "tar") + { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the + -- '--format' option. + programPostConf = \verbosity tarProg -> do + tarHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation tarProg ["--help"]) + -- Some versions of tar don't support '--help'. + `catchIO` (\_ -> return "") + let k = "Supports --format" + v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + m = Map.insert k v (programProperties tarProg) + return $ tarProg{programProperties = m} + } + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pkgConfigProgram :: Program +pkgConfigProgram = + (simpleProgram "pkg-config") + { programFindVersion = findProgramVersion "--version" id + , programPostConf = \_ pkgConfProg -> + let programOverrideEnv' = + programOverrideEnv pkgConfProg + ++ [ ("PKG_CONFIG_ALLOW_SYSTEM_CFLAGS", Just "1") + , ("PKG_CONFIG_ALLOW_SYSTEM_LIBS", Just "1") + ] + in pure $ pkgConfProg{programOverrideEnv = programOverrideEnv'} + } diff --git a/src/Distribution/Simple/Program/Db.hs b/src/Distribution/Simple/Program/Db.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Db.hs @@ -0,0 +1,566 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Db +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides a 'ProgramDb' type which holds configured and not-yet +-- configured programs. It is the parameter to lots of actions elsewhere in +-- Cabal that need to look up and run programs. If we had a Cabal monad, +-- the 'ProgramDb' would probably be a reader or state component of it. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. +module Distribution.Simple.Program.Db + ( -- * The collection of configured programs we can run + ProgramDb (..) + , emptyProgramDb + , defaultProgramDb + , restoreProgramDb + + -- ** Query and manipulate the program db + , addKnownProgram + , addKnownPrograms + , prependProgramSearchPath + , prependProgramSearchPathNoLogging + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , modifyProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramByName + , updateProgram + , configuredPrograms + + -- ** Query and manipulate the program db + , configureProgram + , configureUnconfiguredProgram + , configureAllKnownPrograms + , unconfigureProgram + , lookupProgramVersion + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + + -- * Internal functions + , UnconfiguredProgs + , ConfiguredProgs + , updateUnconfiguredProgs + , updateConfiguredProgs + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Utils.Structured (Structure (..), Structured (..)) +import Distribution.Verbosity +import Distribution.Version + +import Data.Tuple (swap) + +import qualified Data.Map as Map +import Distribution.Simple.Errors + +-- ------------------------------------------------------------ + +-- * Programs database + +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramDb = ProgramDb + { unconfiguredProgs :: UnconfiguredProgs + , progSearchPath :: ProgramSearchPath + , progOverrideEnv :: [(String, Maybe String)] + , configuredProgs :: ConfiguredProgs + } + +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + +emptyProgramDb :: ProgramDb +emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath [] Map.empty + +defaultProgramDb :: ProgramDb +defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb + +-- internal helpers: +updateUnconfiguredProgs + :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb + -> ProgramDb +updateUnconfiguredProgs update progdb = + progdb{unconfiguredProgs = update (unconfiguredProgs progdb)} + +updateConfiguredProgs + :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb + -> ProgramDb +updateConfiguredProgs update progdb = + progdb{configuredProgs = update (configuredProgs progdb)} + +-- Read & Show instances are based on listToFM + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +instance Show ProgramDb where + show = show . Map.toAscList . configuredProgs + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +instance Read ProgramDb where + readsPrec p s = + [ (emptyProgramDb{configuredProgs = Map.fromList s'}, r) + | (s', r) <- readsPrec p s + ] + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +instance Binary ProgramDb where + put db = do + put (progSearchPath db) + put (progOverrideEnv db) + put (configuredProgs db) + + get = do + searchpath <- get + overrides <- get + progs <- get + return $! + emptyProgramDb + { progSearchPath = searchpath + , progOverrideEnv = overrides + , configuredProgs = progs + } + +instance Structured ProgramDb where + structure p = + Nominal + (typeRep p) + 0 + "ProgramDb" + [ structure (Proxy :: Proxy ProgramSearchPath) + , structure (Proxy :: Proxy [(String, Maybe String)]) + , structure (Proxy :: Proxy ConfiguredProgs) + ] + +-- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the +-- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because +-- it contains functions. So to fully restore a deserialised 'ProgramDb' use +-- this function to add back all the known 'Program's. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb +restoreProgramDb = addKnownPrograms + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +addKnownProgram :: Program -> ProgramDb -> ProgramDb +addKnownProgram prog = + updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where + combine _ (_, path, args) = (prog, path, args) + +addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb +addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs + +lookupKnownProgram :: String -> ProgramDb -> Maybe Program +lookupKnownProgram name = + fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs + +knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] +knownPrograms progdb = + [ (p, p') | (p, _, _) <- Map.elems (unconfiguredProgs progdb), let p' = Map.lookup (programName p) (configuredProgs progdb) + ] + +-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This is the default list of locations where programs are looked for when +-- configuring them. This can be overridden for specific programs (with +-- 'userSpecifyPath'), and specific known programs can modify or ignore this +-- search path in their own configuration code. +getProgramSearchPath :: ProgramDb -> ProgramSearchPath +getProgramSearchPath = progSearchPath + +-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This will affect programs that are configured from here on, so you +-- should usually set it before configuring any programs. +setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb +setProgramSearchPath searchpath db = db{progSearchPath = searchpath} + +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This will affect programs that are configured from here on, so you +-- should usually modify it before configuring any programs. +modifyProgramSearchPath + :: (ProgramSearchPath -> ProgramSearchPath) + -> ProgramDb + -> ProgramDb +modifyProgramSearchPath f db = + setProgramSearchPath (f $ getProgramSearchPath db) db + +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb' +-- by prepending the provided extra paths. +-- +-- - Logs the added paths in info verbosity. +-- - Prepends environment variable overrides. +prependProgramSearchPath + :: Verbosity + -> [FilePath] + -> [(String, Maybe FilePath)] + -> ProgramDb + -> IO ProgramDb +prependProgramSearchPath verbosity extraPaths extraEnv db = do + unless (null extraPaths) $ + logExtraProgramSearchPath verbosity extraPaths + unless (null extraEnv) $ + logExtraProgramOverrideEnv verbosity extraEnv + return $ prependProgramSearchPathNoLogging extraPaths extraEnv db + +prependProgramSearchPathNoLogging + :: [FilePath] + -> [(String, Maybe String)] + -> ProgramDb + -> ProgramDb +prependProgramSearchPathNoLogging extraPaths extraEnv db = + let db' = modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db + db'' = db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'} + in db'' + +-- | User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +userSpecifyPath + :: String + -- ^ Program name + -> FilePath + -- ^ user-specified path to the program + -> ProgramDb + -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ + \(prog, _, args) -> Just (prog, Just path, args) + +userMaybeSpecifyPath + :: String + -> Maybe FilePath + -> ProgramDb + -> ProgramDb +userMaybeSpecifyPath _ Nothing progdb = progdb +userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb + +-- | User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs + :: String + -- ^ Program name + -> [ProgArg] + -- ^ user-specified args + -> ProgramDb + -> ProgramDb +userSpecifyArgs name args' = + updateUnconfiguredProgs + ( flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args') + ) + . updateConfiguredProgs + ( flip Map.update name $ + \prog -> + Just + prog + { programOverrideArgs = + programOverrideArgs prog + ++ args' + } + ) + +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +userSpecifyPaths + :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb +userSpecifyPaths paths progdb = + foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +userSpecifyArgss + :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb +userSpecifyArgss argss progdb = + foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss + +-- | Get the path that has been previously specified for a program, if any. +userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs + +-- | Get any extra args that have been previously specified for a program. +userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_, _, as) -> as) . Map.lookup (programName prog) . unconfiguredProgs + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram +lookupProgram = lookupProgramByName . programName + +-- | Try to find a configured program +lookupProgramByName :: String -> ProgramDb -> Maybe ConfiguredProgram +lookupProgramByName name = Map.lookup name . configuredProgs + +-- | Update a configured program in the database. +updateProgram + :: ConfiguredProgram + -> ProgramDb + -> ProgramDb +updateProgram prog = + updateConfiguredProgs $ + Map.insert (programId prog) prog + +-- | List all configured programs. +configuredPrograms :: ProgramDb -> [ConfiguredProgram] +configuredPrograms = Map.elems . configuredProgs + +-- --------------------------- +-- Configuring known programs + +-- | Try to configure a specific program and add it to the program database. +-- +-- If the program is already included in the collection of unconfigured programs, +-- then we use any user-supplied location and arguments. +-- If the program gets configured successfully, it gets added to the configured +-- collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- The reason for it not being a failure at this stage is that we don't know up +-- front all the programs we will need, so we try to configure them all. +-- To verify that a program was actually successfully configured use +-- 'requireProgram'. +configureProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb +configureProgram verbosity prog progdb = do + mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb + case mbConfiguredProg of + Nothing -> return progdb + Just configuredProg -> do + let progdb' = + updateConfiguredProgs + (Map.insert (programName prog) configuredProg) + progdb + return progdb' + +-- | Try to configure a specific program. If the program is already included in +-- the collection of unconfigured programs then we use any user-supplied +-- location and arguments. +configureUnconfiguredProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe ConfiguredProgram) +configureUnconfiguredProgram verbosity prog progdb = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog progdb of + Nothing -> + programFindLocation prog verbosity (progSearchPath progdb) + >>= return . fmap (swap . fmap FoundOnSystem . swap) + Just path -> do + absolute <- doesExecutableExist path + if absolute + then return (Just (UserSpecified path, [])) + else + findProgramOnSearchPath verbosity (progSearchPath progdb) path + >>= maybe + (dieWithException verbosity $ ConfigureProgram name path) + (return . Just . swap . fmap UserSpecified . swap) + case maybeLocation of + Nothing -> return Nothing + Just (location, triedLocations) -> do + version <- programFindVersion prog verbosity (locationPath location) + newPath <- programSearchPathAsPATHVar (progSearchPath progdb) + let configuredProg = + ConfiguredProgram + { programId = name + , programVersion = version + , programDefaultArgs = [] + , programOverrideArgs = userSpecifiedArgs prog progdb + , programOverrideEnv = [("PATH", Just newPath)] ++ progOverrideEnv progdb + , programProperties = Map.empty + , programLocation = location + , programMonitorFiles = triedLocations + } + configuredProg' <- programPostConf prog verbosity configuredProg + return $ Just configuredProg' + +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +configurePrograms + :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb +configurePrograms verbosity progs progdb = + foldM (flip (configureProgram verbosity)) progdb progs + +-- | Unconfigure a program. This is basically a hack and you shouldn't +-- use it, but it can be handy for making sure a 'requireProgram' +-- actually reconfigures. +unconfigureProgram :: String -> ProgramDb -> ProgramDb +unconfigureProgram progname = + updateConfiguredProgs $ Map.delete progname + +-- | Try to configure all the known programs that have not yet been configured. +configureAllKnownPrograms + :: Verbosity + -> ProgramDb + -> IO ProgramDb +configureAllKnownPrograms verbosity progdb = + configurePrograms + verbosity + [prog | (prog, _, _) <- Map.elems notYetConfigured] + progdb + where + notYetConfigured = + unconfiguredProgs progdb + `Map.difference` configuredProgs progdb + +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +reconfigurePrograms + :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb +reconfigurePrograms verbosity paths argss progdb = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ progdb + where + progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] + +-- | Check that a program is configured and available to be run. +-- +-- It raises an exception if the program could not be configured, otherwise +-- it returns the configured program. +requireProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) +requireProgram verbosity prog progdb = do + mres <- needProgram verbosity prog progdb + case mres of + Nothing -> dieWithException verbosity $ RequireProgram (programName prog) + Just res -> return res + +-- | Check that a program is configured and available to be run. +-- +-- It returns 'Nothing' if the program couldn't be configured, +-- or is not found. +-- +-- @since 3.0.1.0 +needProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe (ConfiguredProgram, ProgramDb)) +needProgram verbosity prog progdb = do + -- If it's not already been configured, try to configure it now + progdb' <- case lookupProgram prog progdb of + Nothing -> configureProgram verbosity prog progdb + Just _ -> return progdb + + case lookupProgram prog progdb' of + Nothing -> return Nothing + Just configuredProg -> return (Just (configuredProg, progdb')) + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the program version number is suitable and return +-- it. For example you could require 'AnyVersion' or @'orLaterVersion' +-- ('Version' [1,0] [])@ +-- +-- It returns the configured program, its version number and a possibly updated +-- 'ProgramDb'. If the program could not be configured or the version is +-- unsuitable, it returns an error value. +lookupProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb)) +lookupProgramVersion verbosity prog range programDb = do + -- If it's not already been configured, try to configure it now + programDb' <- case lookupProgram prog programDb of + Nothing -> configureProgram verbosity prog programDb + Just _ -> return programDb + + case lookupProgram prog programDb' of + Nothing -> return $! Left $ NoProgramFound (programName prog) range + Just configuredProg@ConfiguredProgram{programLocation = location} -> + case programVersion configuredProg of + Just version + | withinRange version range -> + return $! Right (configuredProg, version, programDb') + | otherwise -> + return $! Left $ BadVersionDb (programName prog) version range (locationPath location) + Nothing -> + return $! Left $ UnknownVersionDb (programName prog) range (locationPath location) + +-- | Like 'lookupProgramVersion', but raises an exception in case of error +-- instead of returning 'Left errMsg'. +requireProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range programDb = + join $ + either (dieWithException verbosity) return + `fmap` lookupProgramVersion verbosity prog range programDb diff --git a/src/Distribution/Simple/Program/Find.hs b/src/Distribution/Simple/Program/Find.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Find.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Find +-- Copyright : Duncan Coutts 2013 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A somewhat extended notion of the normal program search path concept. +-- +-- Usually when finding executables we just want to look in the usual places +-- using the OS's usual method for doing so. In Haskell the normal OS-specific +-- method is captured by 'findExecutable'. On all common OSs that makes use of +-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@). +-- +-- However it is sometimes useful to be able to look in additional locations +-- without having to change the process-global @PATH@ environment variable. +-- So we need an extension of the usual 'findExecutable' that can look in +-- additional locations, either before, after or instead of the normal OS +-- locations. +module Distribution.Simple.Program.Find + ( -- * Program search path + ProgramSearchPath + , ProgramSearchPathEntry (..) + , defaultProgramSearchPath + , findProgramOnSearchPath + , programSearchPathAsPATHVar + , logExtraProgramSearchPath + , logExtraProgramOverrideEnv + , getSystemSearchPath + , getExtraPathEnv + , simpleProgram + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Environment +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Verbosity + +import qualified System.Directory as Directory + ( findExecutable + ) +import System.FilePath as FilePath + ( getSearchPath + , searchPathSeparator + , splitSearchPath + , takeDirectory + , (<.>) + , () + ) +#if defined(mingw32_HOST_OS) +import qualified System.Win32 as Win32 +#endif + +defaultProgramSearchPath :: ProgramSearchPath +defaultProgramSearchPath = [ProgramSearchPathDefault] + +logExtraProgramSearchPath + :: Verbosity + -> [FilePath] + -> IO () +logExtraProgramSearchPath verbosity extraPaths = + info verbosity . unlines $ + "Including the following directories in PATH:" + : map ("- " ++) extraPaths + +logExtraProgramOverrideEnv + :: Verbosity + -> [(String, Maybe String)] + -> IO () +logExtraProgramOverrideEnv verbosity extraEnv = + info verbosity . unlines $ + "Including the following environment variable overrides:" + : [ "- " ++ case mbVal of + Nothing -> "unset " ++ var + Just val -> var ++ "=" ++ val + | (var, mbVal) <- extraEnv + ] + +findProgramOnSearchPath + :: Verbosity + -> ProgramSearchPath + -> FilePath + -> IO (Maybe (FilePath, [FilePath])) +findProgramOnSearchPath verbosity searchpath prog = do + debug verbosity $ "Searching for " ++ prog ++ " in path." + res <- tryPathElems [] searchpath + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at " ++ path) + return res + where + tryPathElems + :: [[FilePath]] + -> [ProgramSearchPathEntry] + -> IO (Maybe (FilePath, [FilePath])) + tryPathElems _ [] = return Nothing + tryPathElems tried (pe : pes) = do + res <- tryPathElem pe + case res of + (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes + (Just foundat, notfoundat) -> return (Just (foundat, alltried)) + where + alltried = concat (reverse (notfoundat : tried)) + + tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) + tryPathElem (ProgramSearchPathDir dir) = + findFirstExe [dir prog <.> ext | ext <- exeExtensions] + -- On windows, getSystemSearchPath is not guaranteed 100% correct so we + -- use findExecutable and then approximate the not-found-at locations. + tryPathElem ProgramSearchPathDefault | buildOS == Windows = do + mExe <- firstJustM [findExecutable (prog <.> ext) | ext <- exeExtensions] + syspath <- getSystemSearchPath + case mExe of + Nothing -> + let notfoundat = [dir prog | dir <- syspath] + in return (Nothing, notfoundat) + Just foundat -> do + let founddir = takeDirectory foundat + notfoundat = + [ dir prog + | dir <- takeWhile (/= founddir) syspath + ] + return (Just foundat, notfoundat) + + -- On other OSs we can just do the simple thing + tryPathElem ProgramSearchPathDefault = do + dirs <- getSystemSearchPath + findFirstExe [dir prog <.> ext | dir <- dirs, ext <- exeExtensions] + + findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) + findFirstExe = go [] + where + go fs' [] = return (Nothing, reverse fs') + go fs' (f : fs) = do + isExe <- doesExecutableExist f + if isExe + then return (Just f, reverse fs') + else go (f : fs') fs + + -- Helper for evaluating actions until the first one returns 'Just' + firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) + firstJustM [] = return Nothing + firstJustM (ma : mas) = do + a <- ma + case a of + Just _ -> return a + Nothing -> firstJustM mas + +-- | Adds some paths to the "PATH" entry in the key-value environment provided +-- or if there is none, looks up @$PATH@ in the real environment. +getExtraPathEnv + :: Verbosity + -> [(String, Maybe String)] + -> [FilePath] + -> IO [(String, Maybe String)] +getExtraPathEnv _ _ [] = return [] +getExtraPathEnv verbosity env extras = do + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + logExtraProgramSearchPath verbosity extras + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] + +-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. +-- Note that this is close but not perfect because on Windows the search +-- algorithm looks at more than just the @%PATH%@. +programSearchPathAsPATHVar :: ProgramSearchPath -> IO String +programSearchPathAsPATHVar searchpath = do + ess <- traverse getEntries searchpath + return (intercalate [searchPathSeparator] (concat ess)) + where + getEntries (ProgramSearchPathDir dir) = return [dir] + getEntries ProgramSearchPathDefault = do + env <- getEnvironment + return (maybe [] splitSearchPath (lookup "PATH" env)) + +-- | Get the system search path. On Unix systems this is just the @$PATH@ env +-- var, but on windows it's a bit more complicated. +getSystemSearchPath :: IO [FilePath] +getSystemSearchPath = fmap nub $ do +#if defined(mingw32_HOST_OS) + processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE + currentdir <- Win32.getCurrentDirectory + systemdir <- Win32.getSystemDirectory + windowsdir <- Win32.getWindowsDirectory + pathdirs <- FilePath.getSearchPath + let path = processdir : currentdir + : systemdir : windowsdir + : pathdirs + return path +#else + FilePath.getSearchPath +#endif + +#ifdef MIN_VERSION_directory +#if MIN_VERSION_directory(1,2,1) +#define HAVE_directory_121 +#endif +#endif + +findExecutable :: FilePath -> IO (Maybe FilePath) +#ifdef HAVE_directory_121 +findExecutable = Directory.findExecutable +#else +findExecutable prog = do + -- With directory < 1.2.1 'findExecutable' doesn't check that the path + -- really refers to an executable. + mExe <- Directory.findExecutable prog + case mExe of + Just exe -> do + exeExists <- doesExecutableExist exe + if exeExists + then return mExe + else return Nothing + _ -> return mExe +#endif + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } +simpleProgram :: String -> Program +simpleProgram name = + Program + { programName = name + , programFindLocation = \v p -> findProgramOnSearchPath v p name + , programFindVersion = \_ _ -> return Nothing + , programPostConf = \_ p -> return p + , programNormaliseArgs = \_ _ -> id + } diff --git a/src/Distribution/Simple/Program/GHC.hs b/src/Distribution/Simple/Program/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/GHC.hs @@ -0,0 +1,1085 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Simple.Program.GHC + ( GhcOptions (..) + , GhcMode (..) + , GhcOptimisation (..) + , GhcDynLinkMode (..) + , GhcProfAuto (..) + , ghcInvocation + , renderGhcOptions + , runGHC + , runGHCWithResponseFile + , runReplProgram + , packageDbArgsDb + , normaliseGhcArgs + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..)) +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.Program.Find (getExtraPathEnv) +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils (TempFileOptions, infoNoWrap) +import Distribution.System +import Distribution.Types.ComponentId +import Distribution.Types.ParStrat +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version + +import GHC.IO.Encoding (TextEncoding) +import Language.Haskell.Extension + +import Data.List (stripPrefix) +import qualified Data.Map as Map +import Data.Monoid (All (..), Any (..), Endo (..)) +import qualified Data.Set as Set +import qualified System.Process as Process + +normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] +normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs + | ghcVersion `withinRange` supportedGHCVersions = + argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs + where + supportedGHCVersions :: VersionRange + supportedGHCVersions = orLaterVersion (mkVersion [8, 0]) + -- we (weakly) support unknown future GHC versions for the purpose + -- of filtering GHC arguments + + from :: Monoid m => [Int] -> m -> m + from version flags + | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags + | otherwise = mempty + + to :: Monoid m => [Int] -> m -> m + to version flags + | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags + | otherwise = mempty + + checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m + checkGhcFlags fun = + mconcat + [ fun ghcArgs + , checkComponentFlags libBuildInfo pkgLibs + , checkComponentFlags buildInfo executables + , checkComponentFlags testBuildInfo testSuites + , checkComponentFlags benchmarkBuildInfo benchmarks + ] + where + pkgLibs = maybeToList library ++ subLibraries + + checkComponentFlags :: (a -> BuildInfo) -> [a] -> m + checkComponentFlags getInfo = foldMap (checkComponent . getInfo) + where + checkComponent :: BuildInfo -> m + checkComponent = foldMap fun . filterGhcOptions . allGhcOptions + + allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] + allGhcOptions = + foldMap + (perCompilerFlavorToList .) + [options, profOptions, sharedOptions, staticOptions] + + filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] + filterGhcOptions l = [opts | (GHC, opts) <- l] + + safeToFilterWarnings :: Bool + safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings + where + checkWarnings :: [String] -> All + checkWarnings = All . Set.null . foldr alter Set.empty + + alter :: String -> Set String -> Set String + alter flag = + appEndo $ + mconcat + [ \s -> Endo $ if s == "-Werror" then Set.insert s else id + , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id + , \s -> + from [8, 6] . Endo $ + if s == "-Werror=compat" + then Set.union compatWarningSet + else id + , \s -> + from [8, 6] . Endo $ + if s == "-Wno-error=compat" + then (`Set.difference` compatWarningSet) + else id + , \s -> + from [8, 6] . Endo $ + if s == "-Wwarn=compat" + then (`Set.difference` compatWarningSet) + else id + , from [8, 4] $ markFlag "-Werror=" Set.insert + , from [8, 4] $ markFlag "-Wwarn=" Set.delete + , from [8, 4] $ markFlag "-Wno-error=" Set.delete + ] + flag + + markFlag + :: String + -> (String -> Set String -> Set String) + -> String + -> Endo (Set String) + markFlag name update flag = Endo $ case stripPrefix name flag of + Just rest | not (null rest) && rest /= "compat" -> update rest + _ -> id + + flagArgumentFilter :: [String] -> [String] -> [String] + flagArgumentFilter flags = go + where + makeFilter :: String -> String -> Option' (First' ([String] -> [String])) + makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg + where + filterRest leftOver = case dropEq leftOver of + [] -> drop 1 + _ -> id + + checkFilter :: String -> Maybe ([String] -> [String]) + checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags + + go :: [String] -> [String] + go [] = [] + go (arg : args) = case checkFilter arg of + Just f -> go (f args) + Nothing -> arg : go args + + argumentFilters :: [String] -> [String] + argumentFilters = + flagArgumentFilter + ["-ghci-script", "-H", "-interactive-print"] + + -- \| Remove RTS arguments from a list. + filterRtsArgs :: [String] -> [String] + filterRtsArgs = snd . splitRTSArgs + + simpleFilters :: String -> Bool + simpleFilters = + not + . getAny + . mconcat + [ flagIn simpleFlags + , Any . isPrefixOf "-ddump-" + , Any . isPrefixOf "-dsuppress-" + , Any . isPrefixOf "-dno-suppress-" + , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] + , flagIn . invertibleFlagSet "-f" . mconcat $ + [ + [ "reverse-errors" + , "warn-unused-binds" + , "break-on-error" + , "break-on-exception" + , "print-bind-result" + , "print-bind-contents" + , "print-evld-with-show" + , "implicit-import-qualified" + , "error-spans" + ] + , from + [7, 8] + [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options + , "print-explicit-kinds" + ] + , from + [8, 0] + [ "print-explicit-coercions" + , "print-explicit-runtime-reps" + , "print-equality-relations" + , "print-unicode-syntax" + , "print-expanded-synonyms" + , "print-potential-instances" + , "print-typechecker-elaboration" + ] + , from + [8, 2] + [ "diagnostics-show-caret" + , "local-ghci-history" + , "show-warning-groups" + , "hide-source-paths" + , "show-hole-constraints" + ] + , from [8, 4] ["show-loaded-modules"] + , from [8, 6] ["ghci-leak-check", "no-it"] + , from + [8, 10] + [ "defer-diagnostics" -- affects printing of diagnostics + , "keep-going" -- try harder, the build will still fail if it's erroneous + , "print-axiom-incomps" -- print more debug info for closed type families + ] + , from + [9, 2] + [ "family-application-cache" + ] + , from + [9, 6] + [ "print-redundant-promotion-ticks" + , "show-error-context" + ] + , from + [9, 8] + [ "unoptimized-core-for-interpreter" + ] + , from + [9, 10] + [ "diagnostics-as-json" + , "print-error-index-links" + , "break-points" + ] + ] + , flagIn $ invertibleFlagSet "-d" ["ppr-case-as-let", "ppr-ticks"] + , isOptIntFlag + , isIntFlag + , if safeToFilterWarnings + then isWarning <> (Any . ("-w" ==)) + else mempty + , from [8, 6] $ + if safeToFilterHoles + then isTypedHoleFlag + else mempty + ] + + flagIn :: Set String -> String -> Any + flagIn set flag = Any $ Set.member flag set + + isWarning :: String -> Any + isWarning = + mconcat $ + map + ((Any .) . isPrefixOf) + ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] + + simpleFlags :: Set String + simpleFlags = + Set.fromList . mconcat $ + [ + [ "-n" + , "-#include" + , "-Rghc-timing" + , "-dstg-stats" + , "-dth-dec-file" + , "-dsource-stats" + , "-dverbose-core2core" + , "-dverbose-stg2stg" + , "-dcore-lint" + , "-dstg-lint" + , "-dcmm-lint" + , "-dasm-lint" + , "-dannot-lint" + , "-dshow-passes" + , "-dfaststring-stats" + , "-fno-max-relevant-binds" + , "-recomp" + , "-no-recomp" + , "-fforce-recomp" + , "-fno-force-recomp" + ] + , from + [8, 2] + [ "-fno-max-errors" + , "-fdiagnostics-color=auto" + , "-fdiagnostics-color=always" + , "-fdiagnostics-color=never" + , "-dppr-debug" + , "-dno-debug-output" + ] + , from [8, 4] ["-ddebug-output"] + , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"] + , from [8, 6] ["-dhex-word-literals"] + , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"] + , from [9, 0] ["-dlinear-core-lint"] + , from [9, 10] ["-dipe-stats"] + ] + + isOptIntFlag :: String -> Any + isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] + + isIntFlag :: String -> Any + isIntFlag = + mconcat . map (dropIntFlag False) . mconcat $ + [ + [ "-fmax-relevant-binds" + , "-ddpr-user-length" + , "-ddpr-cols" + , "-dtrace-level" + , "-fghci-hist-size" + , "-dinitial-unique" + , "-dunique-increment" + ] + , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"] + , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"] + , from [9, 12] ["-fmax-forced-spec-args", "-fwrite-if-compression"] + ] + + dropIntFlag :: Bool -> String -> String -> Any + dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of + Nothing -> False + Just rest + | isOpt && null rest -> True + | otherwise -> case parseInt rest of + Just _ -> True + Nothing -> False + where + parseInt :: String -> Maybe Int + parseInt = readMaybe . dropEq + + dropEq :: String -> String + dropEq ('=' : s) = s + dropEq s = s + + invertibleFlagSet :: String -> [String] -> Set String + invertibleFlagSet prefix flagNames = + Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames + + compatWarningSet :: Set String + compatWarningSet = + Set.fromList $ + mconcat + [ from + [8, 6] + [ "missing-monadfail-instances" + , "semigroup" + , "noncanonical-monoid-instances" + , "implicit-kind-vars" + ] + ] + + safeToFilterHoles :: Bool + safeToFilterHoles = + getAll . checkGhcFlags $ + All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred + where + notDeferred :: String -> Option' (Last' Bool) + notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False + notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True + notDeferred _ = Option' Nothing + + isTypedHoleFlag :: String -> Any + isTypedHoleFlag = + mconcat + [ flagIn . invertibleFlagSet "-f" $ + [ "show-hole-constraints" + , "show-valid-substitutions" + , "show-valid-hole-fits" + , "sort-valid-hole-fits" + , "sort-by-size-hole-fits" + , "sort-by-subsumption-hole-fits" + , "abstract-refinement-hole-fits" + , "show-provenance-of-hole-fits" + , "show-hole-matches-of-hole-fits" + , "show-type-of-hole-fits" + , "show-type-app-of-hole-fits" + , "show-type-app-vars-of-hole-fits" + , "unclutter-valid-hole-fits" + ] + , flagIn . Set.fromList $ + [ "-fno-max-valid-hole-fits" + , "-fno-max-refinement-hole-fits" + , "-fno-refinement-level-hole-fits" + ] + , mconcat . map (dropIntFlag False) $ + [ "-fmax-valid-hole-fits" + , "-fmax-refinement-hole-fits" + , "-frefinement-level-hole-fits" + ] + ] +normaliseGhcArgs _ _ args = args + +-- | A structured set of GHC options/flags +-- +-- Note that options containing lists fall into two categories: +-- +-- * options that can be safely deduplicated, e.g. input modules or +-- enabled extensions; +-- * options that cannot be deduplicated in general without changing +-- semantics, e.g. extra ghc options or linking options. +data GhcOptions = GhcOptions + { ghcOptMode :: Flag GhcMode + -- ^ The major mode for the ghc invocation. + , ghcOptExtra :: [String] + -- ^ Any extra options to pass directly to ghc. These go at the end and hence + -- override other stuff. + , ghcOptExtraDefault :: [String] + -- ^ Extra default flags to pass directly to ghc. These go at the beginning + -- and so can be overridden by other stuff. + , ----------------------- + -- Inputs and outputs + + ghcOptInputFiles :: NubListR (SymbolicPath Pkg File) + -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode. + , ghcOptInputScripts :: NubListR (SymbolicPath Pkg File) + -- ^ Script files with irregular extensions that need -x hs. + , ghcOptInputModules :: NubListR ModuleName + -- ^ The names of input Haskell modules, mainly for @--make@ mode. + , ghcOptOutputFile :: Flag (SymbolicPath Pkg File) + -- ^ Location for output file; the @ghc -o@ flag. + , ghcOptOutputDynFile :: Flag FilePath + -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode; + -- the @ghc -dyno@ flag. + , ghcOptSourcePathClear :: Flag Bool + -- ^ Start with an empty search path for Haskell source files; + -- the @ghc -i@ flag (@-i@ on its own with no path argument). + , ghcOptSourcePath :: NubListR (SymbolicPath Pkg (Dir Source)) + -- ^ Search path for Haskell source files; the @ghc -i@ flag. + , ghcOptUnitFiles :: [FilePath] + -- ^ Unit files to load; the @ghc -unit@ flag. + , ------------- + -- Packages + + ghcOptThisUnitId :: Flag String + -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@ + -- flag (or @-this-package-key@ or @-package-name@ on older + -- versions of GHC). This is a 'String' because we assume you've + -- already figured out what the correct format for this string is + -- (we need to handle backwards compatibility.) + , ghcOptThisComponentId :: Flag ComponentId + -- ^ GHC doesn't make any assumptions about the format of + -- definite unit ids, so when we are instantiating a package it + -- needs to be told explicitly what the component being instantiated + -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty + , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the requirements of the package being compiled are to + -- be filled. When typechecking an indefinite package, the 'OpenModule' + -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module + -- that instantiates a package. + , ghcOptNoCode :: Flag Bool + -- ^ No code? (But we turn on interface writing + , ghcOptPackageDBs :: PackageDBStack + -- ^ GHC package databases to use, the @ghc -package-conf@ flag. + , ghcOptPackages + :: NubListR (OpenUnitId, ModuleRenaming) + -- ^ The GHC packages to bring into scope when compiling, + -- the @ghc -package-id@ flags. + , ghcOptHideAllPackages :: Flag Bool + -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag + , ghcOptWarnMissingHomeModules :: Flag Bool + -- ^ Warn about modules, not listed in command line + , ghcOptNoAutoLinkPackages :: Flag Bool + -- ^ Don't automatically link in Haskell98 etc; the @ghc + -- -no-auto-link-packages@ flag. + , ----------------- + -- Linker stuff + + ghcOptLinkLibs :: [FilePath] + -- ^ Names of libraries to link in; the @ghc -l@ flag. + , ghcOptLinkLibPath :: NubListR (SymbolicPath Pkg (Dir Lib)) + -- ^ Search path for libraries to link in; the @ghc -L@ flag. + , ghcOptLinkOptions :: [String] + -- ^ Options to pass through to the linker; the @ghc -optl@ flag. + , ghcOptLinkFrameworks :: NubListR String + -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag. + , ghcOptLinkFrameworkDirs :: NubListR (SymbolicPath Pkg (Dir Framework)) + -- ^ OSX only: Search path for frameworks to link in; the + -- @ghc -framework-path@ flag. + , ghcOptLinkRts :: Flag Bool + -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library. + , ghcOptNoLink :: Flag Bool + -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + , ghcOptLinkNoHsMain :: Flag Bool + -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ + -- flag. + , ghcOptLinkModDefFiles :: NubListR FilePath + -- ^ Module definition files (Windows specific) + , -------------------- + -- C and CPP stuff + + ghcOptCcOptions :: [String] + -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag. + , ghcOptCxxOptions :: [String] + -- ^ Options to pass through to the C++ compiler. + , ghcOptAsmOptions :: [String] + -- ^ Options to pass through to the Assembler. + , ghcOptCppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optP@ flag. + , ghcOptJSppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optJSP@ flag. @since 3.16.0.0 + , ghcOptCppIncludePath :: NubListR (SymbolicPath Pkg (Dir Include)) + -- ^ Search path for CPP includes like header files; the @ghc -I@ flag. + , ghcOptCppIncludes :: NubListR (SymbolicPath Pkg File) + -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + , ghcOptFfiIncludes :: NubListR FilePath + -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag. + , ghcOptCcProgram :: Flag FilePath + -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. + , ---------------------------- + -- Language and extensions + + ghcOptLanguage :: Flag Language + -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + , ghcOptExtensions :: NubListR Extension + -- ^ The language extensions; the @ghc -X@ flag. + , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag) + -- ^ A GHC version-dependent mapping of extensions to flags. This must be + -- set to be able to make use of the 'ghcOptExtensions'. + , ---------------- + -- Compilation + + ghcOptOptimisation :: Flag GhcOptimisation + -- ^ What optimisation level to use; the @ghc -O@ flag. + , ghcOptDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info; the @ghc -g@ flag. + , ghcOptProfilingMode :: Flag Bool + -- ^ Compile in profiling mode; the @ghc -prof@ flag. + , ghcOptProfilingAuto :: Flag GhcProfAuto + -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. + , ghcOptSplitSections :: Flag Bool + -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag. + , ghcOptSplitObjs :: Flag Bool + -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag. + , ghcOptNumJobs :: Flag ParStrat + -- ^ Run N jobs simultaneously (if possible). + , ghcOptHPCDir :: Flag (SymbolicPath Pkg (Dir Mix)) + -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. + , ---------------- + -- GHCi + + ghcOptGHCiScripts :: [FilePath] + -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag + , ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String + , ghcOptObjSuffix :: Flag String + , ghcOptDynHiSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptDynObjSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptHiDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptHieDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptObjDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptOutputDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptStubDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , -------------------- + -- Creating libraries + + ghcOptDynLinkMode :: Flag GhcDynLinkMode + , ghcOptStaticLib :: Flag Bool + , ghcOptShared :: Flag Bool + , ghcOptFPic :: Flag Bool + , ghcOptDylibName :: Flag String + , ghcOptRPaths :: NubListR FilePath + , --------------- + -- Misc flags + + ghcOptVerbosity :: Flag Verbosity + -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build)) + -- ^ Put the extra folders in the PATH environment variable we invoke + -- GHC with + , ghcOptCabal :: Flag Bool + -- ^ Let GHC know that it is Cabal that's calling it. + -- Modifies some of the GHC error messages. + } + deriving (Show, Generic) + +data GhcMode + = -- | @ghc -c@ + GhcModeCompile + | -- | @ghc@ + GhcModeLink + | -- | @ghc --make@ + GhcModeMake + | -- | @ghci@ \/ @ghc --interactive@ + GhcModeInteractive + | -- | @ghc --abi-hash@ + -- | GhcModeDepAnalysis -- ^ @ghc -M@ + -- | GhcModeEvaluate -- ^ @ghc -e@ + GhcModeAbiHash + deriving (Show, Eq) + +data GhcOptimisation + = -- | @-O0@ + GhcNoOptimisation + | -- | @-O@ + GhcNormalOptimisation + | -- | @-O2@ + GhcMaximumOptimisation + | -- | e.g. @-Odph@ + GhcSpecialOptimisation String + deriving (Show, Eq) + +data GhcDynLinkMode + = -- | @-static@ + GhcStaticOnly + | -- | @-dynamic@ + GhcDynamicOnly + | -- | @-static -dynamic-too@ + GhcStaticAndDynamic + deriving (Show, Eq) + +data GhcProfAuto + = -- | @-fprof-auto@ + GhcProfAutoAll + | -- | @-fprof-auto-top@ + GhcProfAutoToplevel + | -- | @-fprof-auto-exported@ + GhcProfAutoExported + | -- | @-fprof-late + GhcProfLate + deriving (Show, Eq) + +runGHC + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runGHC verbosity ghcProg comp platform mbWorkDir opts = do + runProgramInvocation verbosity + =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts + +runGHCWithResponseFile + :: FilePath + -> Maybe TextEncoding + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do + invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts + + let compilerSupportsResponseFiles = + case compilerCompatVersion GHC comp of + -- GHC 9.4 is the first version which supports response files. + Just version -> version >= mkVersion [9, 4] + Nothing -> False + + args = progInvokeArgs invocation + + if not compilerSupportsResponseFiles + then runProgramInvocation verbosity invocation + else do + let (rtsArgs, otherArgs) = splitRTSArgs args + + withResponseFile + verbosity + tempFileOptions + fileNameTemplate + encoding + otherArgs + $ \responseFile -> do + let newInvocation = + invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs} + + infoNoWrap verbosity $ + "GHC response file arguments: " + <> case otherArgs of + [] -> "" + arg : args' -> Process.showCommandForUser arg args' + + runProgramInvocation verbosity newInvocation + +-- Note [Make --interactive the first argument to GHC] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The ghc argument @--interactive@ needs to be the first argument to the +-- ghc invocation, because Haskell Language Server used to rely on this. +-- This was initially changed for Cabal 3.16, but it broke all existing Haskell +-- Language Server prebuilt binaries. +-- To avoid this, we uphold this assumption in Haskell Language Server until the next +-- Cabal release (3.18). +-- +-- The solution is to make sure that @--interactive@ is not passed as an argument in +-- the response file that is usually passed to ghc. +-- Instead, we filter out @--interactive@ and always pass it as the first argument, +-- if it exists. +-- +-- We plan to remove this Hack in Cabal 3.18. + +-- Start the repl. Either use `ghc`, or the program specified by the --with-repl flag. +runReplProgram + :: Maybe FilePath + -- ^ --with-repl argument + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runReplProgram withReplProg _tempFileOptions verbosity ghcProg comp platform mbWorkDir ghcOpts = + let replProg = case withReplProg of + Just path -> ghcProg{programLocation = FoundOnSystem path} + Nothing -> ghcProg + in do + -- in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts + -- See Note [Make --interactive the first argument to GHC] + -- In Cabal 3.18, restore the line above. + invocation <- ghcInvocation verbosity replProg comp platform mbWorkDir ghcOpts + let invocation' = + let + argsWithoutInteractive = filter (/= "--interactive") (progInvokeArgs invocation) + in + invocation + { progInvokeArgs = ["--interactive"] <> argsWithoutInteractive + } + runProgramInvocation verbosity invocation' + +ghcInvocation + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO ProgramInvocation +ghcInvocation verbosity ghcProg comp platform mbWorkDir opts = do + -- NOTE: GHC is the only program whose path we modify with more values than + -- the standard @extra-prog-path@, namely the folders of the executables in + -- the components, see @componentGhcOptions@. + let envOverrides = programOverrideEnv ghcProg + extraPath <- + getExtraPathEnv verbosity envOverrides $ + map getSymbolicPath $ + fromNubListR $ + ghcOptExtraPath opts + let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath} + return $ + programInvocationCwd mbWorkDir ghcProg' $ + renderGhcOptions comp platform opts + +-- TODO: use the -working-dir GHC flag instead of setting the process +-- working directory, as this improves error messages. + +renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] +renderGhcOptions comp _platform@(Platform _arch os) opts + | compilerFlavor comp `notElem` [GHC, GHCJS] = + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + | otherwise = + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] + , -- Just GhcModeDepAnalysis -> ["-M"] + -- Just GhcModeEvaluate -> ["-e", expr] + + ghcOptExtraDefault opts + , ["-no-link" | flagBool ghcOptNoLink] + , ["-flink-rts" | flagBool ghcOptLinkRts] + , --------------- + -- Misc flags + + maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + , ["-fbuilding-cabal-package" | flagBool ghcOptCabal] + , ---------------- + -- Compilation + + case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + , case flagToMaybe (ghcOptDebugInfo opts) of + Nothing -> [] + Just NoDebugInfo -> [] + Just MinimalDebugInfo -> ["-g1"] + Just NormalDebugInfo -> ["-g2"] + Just MaximalDebugInfo -> ["-g3"] + , ["-prof" | flagBool ghcOptProfilingMode] + , case flagToMaybe (ghcOptProfilingAuto opts) of + _ + | not (flagBool ghcOptProfilingMode) -> + [] + Nothing -> [] + Just GhcProfAutoAll + | flagProfAuto implInfo -> ["-fprof-auto"] + | otherwise -> ["-auto-all"] -- not the same, but close + Just GhcProfLate + | flagProfLate implInfo -> ["-fprof-late"] + | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have. + Just GhcProfAutoToplevel + | flagProfAuto implInfo -> ["-fprof-auto-top"] + | otherwise -> ["-auto-all"] + Just GhcProfAutoExported + | flagProfAuto implInfo -> ["-fprof-auto-exported"] + | otherwise -> ["-auto"] + , ["-split-sections" | flagBool ghcOptSplitSections] + , case compilerCompatVersion GHC comp of + -- the -split-objs flag was removed in GHC 9.8 + Just ver | ver >= mkVersion [9, 8] -> [] + _ -> ["-split-objs" | flagBool ghcOptSplitObjs] + , case flagToMaybe (ghcOptHPCDir opts) of + Nothing -> [] + Just hpcdir -> ["-fhpc", "-hpcdir", u hpcdir] + , if parmakeSupported comp + then case ghcOptNumJobs opts of + NoFlag -> [] + Flag Serial -> [] + Flag (UseSem name) -> + if jsemSupported comp + then ["-jsem " ++ name] + else [] + Flag (NumJobs n) -> ["-j" ++ maybe "" show n] + else [] + , -------------------- + -- Creating libraries + + ["-staticlib" | flagBool ghcOptStaticLib] + , ["-shared" | flagBool ghcOptShared] + , case flagToMaybe (ghcOptDynLinkMode opts) of + Nothing -> [] + Just GhcStaticOnly -> ["-static"] + Just GhcDynamicOnly -> ["-dynamic"] + Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , ["-fPIC" | flagBool ghcOptFPic] + , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName] + , ------------------------ + -- Redirecting outputs + + concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix] + , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix] + , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix] + , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix] + , concat [["-outputdir", u dir] | dir <- flag ghcOptOutputDir] + , concat [["-odir", u dir] | dir <- flag ghcOptObjDir] + , concat [["-hidir", u dir] | dir <- flag ghcOptHiDir] + , concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir] + , concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir] + , ----------------------- + -- Source search path + + ["-i" | flagBool ghcOptSourcePathClear] + , ["-i" ++ u dir | dir <- flags ghcOptSourcePath] + , -------------------- + + -------------------- + -- CPP, C, and C++ stuff + + ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath] + , ["-optP" ++ opt | opt <- ghcOptCppOptions opts] + , ["-optJSP" ++ opt | opt <- ghcOptJSppOptions opts] + , concat + [ ["-optP-include", "-optP" ++ u inc] + | inc <- flags ghcOptCppIncludes + ] + , ["-optc" ++ opt | opt <- ghcOptCcOptions opts] + , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + let cxxflag = case compilerCompatVersion GHC comp of + Just v | v >= mkVersion [8, 10] -> "-optcxx" + _ -> "-optc" + in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts] + , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts] + , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram] + , ----------------- + -- Linker stuff + + ["-optl" ++ opt | opt <- ghcOptLinkOptions opts] + , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] + , ["-L" ++ u dir | dir <- flags ghcOptLinkLibPath] + , if isOSX + then + concat + [ ["-framework", fmwk] + | fmwk <- flags ghcOptLinkFrameworks + ] + else [] + , if isOSX + then + concat + [ ["-framework-path", u path] + | path <- flags ghcOptLinkFrameworkDirs + ] + else [] + , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain] + , ["-dynload deploy" | not (null (flags ghcOptRPaths))] + , ["-optl-Wl,-rpath," ++ dir | dir <- flags ghcOptRPaths] + , flags ghcOptLinkModDefFiles + , ------------- + -- Packages + + concat + [ [ if + | unitIdSupported comp -> "-this-unit-id" + | packageKeySupported comp -> "-this-package-key" + | otherwise -> "-package-name" + , this_arg + ] + | this_arg <- flag ghcOptThisUnitId + ] + , concat + [ ["-this-component-id", prettyShow this_cid] + | this_cid <- flag ghcOptThisComponentId + ] + , if null (ghcOptInstantiatedWith opts) + then [] + else + "-instantiated-with" + : intercalate + "," + ( map + ( \(n, m) -> + prettyShow n + ++ "=" + ++ prettyShow m + ) + (ghcOptInstantiatedWith opts) + ) + : [] + , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode] + , ["-hide-all-packages" | flagBool ghcOptHideAllPackages] + , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules] + , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages] + , packageDbArgs implInfo (interpretPackageDBStack Nothing (ghcOptPackageDBs opts)) + , concat $ + let space "" = "" + space xs = ' ' : xs + in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] + | (ipkgid, rns) <- flags ghcOptPackages + ] + , ---------------------------- + -- Language and extensions + + if supportsHaskell2010 implInfo + then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] + else [] + , [ ext' + | ext <- flags ghcOptExtensions + , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of + Just (Just arg) -> [arg] + Just Nothing -> [] + Nothing -> + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ prettyShow ext + ++ " not present in ghcOptExtensionMap." + ] + , ---------------- + -- GHCi + + concat + [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo + ] + , --------------- + -- Inputs + + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. + map u $ flags ghcOptInputFiles + , concat [["-x", "hs", u script] | script <- flags ghcOptInputScripts] + , [prettyShow modu | modu <- flags ghcOptInputModules] + , concat [["-o", u out] | out <- flag ghcOptOutputFile] + , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile] + , -- unit files + concat [["-unit", "@" ++ unit] | unit <- ghcOptUnitFiles opts] + , --------------- + -- Extra + + ghcOptExtra opts + ] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + implInfo = getImplInfo comp + isOSX = os == OSX + flag flg = flagToList (flg opts) + flags flg = fromNubListR . flg $ opts + flagBool flg = fromFlagOrDefault False (flg opts) + +verbosityOpts :: Verbosity -> [String] +verbosityOpts verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +-- | GHC <7.6 uses '-package-conf' instead of '-package-db'. +packageDbArgsConf :: PackageDBStackCWD -> [String] +packageDbArgsConf dbstack = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> concatMap specific dbs + (GlobalPackageDB : dbs) -> + ("-no-user-package-conf") + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = ["-package-conf", db] + specific _ = ierror + ierror = + error $ + "internal error: unexpected package db stack: " + ++ show dbstack + +-- | GHC >= 7.6 uses the '-package-db' flag. See +-- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. +packageDbArgsDb :: PackageDBStackCWD -> [String] +-- special cases to make arguments prettier in common scenarios +packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB : dbs) + | all isSpecific dbs -> + "-no-user-package-db" + : concatMap single dbs + dbs -> + "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = ["-package-db", db] + single GlobalPackageDB = ["-global-package-db"] + single UserPackageDB = ["-user-package-db"] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False + +packageDbArgs :: GhcImplInfo -> PackageDBStackCWD -> [String] +packageDbArgs implInfo + | flagPackageConf implInfo = packageDbArgsConf + | otherwise = packageDbArgsDb + +-- | Split a list of command-line arguments into RTS arguments and non-RTS +-- arguments. +splitRTSArgs :: [String] -> ([String], [String]) +splitRTSArgs args = + let addRTSArg arg ~(rtsArgs, nonRTSArgs) = (arg : rtsArgs, nonRTSArgs) + addNonRTSArg arg ~(rtsArgs, nonRTSArgs) = (rtsArgs, arg : nonRTSArgs) + + go _ [] = ([], []) + go isRTSArg (arg : rest) = + case arg of + "+RTS" -> addRTSArg arg $ go True rest + "-RTS" -> addRTSArg arg $ go False rest + "--RTS" -> ([arg], rest) + "--" -> ([], arg : rest) + _ -> + if isRTSArg + then addRTSArg arg $ go isRTSArg rest + else addNonRTSArg arg $ go isRTSArg rest + in go False args + +-- ----------------------------------------------------------------------------- +-- Boilerplate Monoid instance for GhcOptions + +instance Monoid GhcOptions where + mempty = gmempty + mappend = (<>) + +instance Semigroup GhcOptions where + (<>) = gmappend diff --git a/src/Distribution/Simple/Program/HcPkg.hs b/src/Distribution/Simple/Program/HcPkg.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/HcPkg.hs @@ -0,0 +1,596 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.HcPkg +-- Copyright : Duncan Coutts 2009, 2013 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and GHCJS have hc-pkg programs. +module Distribution.Simple.Program.HcPkg + ( -- * Types + HcPkgInfo (..) + , RegisterOptions (..) + , defaultRegisterOptions + + -- * Actions + , init + , invoke + , register + , unregister + , recache + , expose + , hide + , dump + , describe + , list + + -- * Program invocations + , initInvocation + , registerInvocation + , unregisterInvocation + , recacheInvocation + , exposeInvocation + , hideInvocation + , dumpInvocation + , describeInvocation + , listInvocation + ) where + +import Distribution.Compat.Prelude hiding (init) +import Prelude () + +import Distribution.InstalledPackageInfo +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Utils.Path +import Distribution.Verbosity + +import Data.List (stripPrefix) +import System.FilePath as FilePath + ( isPathSeparator + , joinPath + , splitDirectories + , splitPath + ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE +import qualified System.FilePath.Posix as FilePath.Posix + +-- | Information about the features and capabilities of an @hc-pkg@ +-- program. +data HcPkgInfo = HcPkgInfo + { hcPkgProgram :: ConfiguredProgram + , noPkgDbStack :: Bool + -- ^ no package DB stack supported + , noVerboseFlag :: Bool + -- ^ hc-pkg does not support verbosity flags + , flagPackageConf :: Bool + -- ^ use package-conf option instead of package-db + , supportsDirDbs :: Bool + -- ^ supports directory style package databases + , requiresDirDbs :: Bool + -- ^ requires directory style package databases + , nativeMultiInstance :: Bool + -- ^ supports --enable-multi-instance flag + , recacheMultiInstance :: Bool + -- ^ supports multi-instance via recache + , suppressFilesCheck :: Bool + -- ^ supports --force-files or equivalent + } + +-- | Call @hc-pkg@ to initialise a package database at the location {path}. +-- +-- > hc-pkg init {path} +init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () +init hpi verbosity preferCompat path + | not (supportsDirDbs hpi) + || (not (requiresDirDbs hpi) && preferCompat) = + writeFile path "[]" + | otherwise = + runProgramInvocation verbosity (initInvocation hpi verbosity path) + +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the +-- provided command-line arguments to it. +invoke + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> [String] + -> IO () +invoke hpi verbosity mbWorkDir dbStack extraArgs = + runProgramInvocation verbosity invocation + where + args = packageDbStackOpts hpi dbStack ++ extraArgs + invocation = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args + +-- | Additional variations in the behaviour for 'register'. +data RegisterOptions = RegisterOptions + { registerAllowOverwrite :: Bool + -- ^ Allows re-registering \/ overwriting an existing package + , registerMultiInstance :: Bool + -- ^ Insist on the ability to register multiple instances of a + -- single version of a single package. This will fail if the @hc-pkg@ + -- does not support it, see 'nativeMultiInstance' and + -- 'recacheMultiInstance'. + , registerSuppressFilesCheck :: Bool + -- ^ Require that no checks are performed on the existence of package + -- files mentioned in the registration info. This must be used if + -- registering prior to putting the files in their final place. This will + -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. + } + +-- | Defaults are @True@, @False@ and @False@ +defaultRegisterOptions :: RegisterOptions +defaultRegisterOptions = + RegisterOptions + { registerAllowOverwrite = True + , registerMultiInstance = False + , registerSuppressFilesCheck = False + } + +-- | Call @hc-pkg@ to register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-db] +register + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> RegisterOptions + -> IO () +register hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions + | registerMultiInstance registerOptions + , not (nativeMultiInstance hpi || recacheMultiInstance hpi) = + dieWithException verbosity RegMultipleInstancePkg + | registerSuppressFilesCheck registerOptions + , not (suppressFilesCheck hpi) = + dieWithException verbosity SuppressingChecksOnFile + -- This is a trick. Older versions of GHC do not support the + -- --enable-multi-instance flag for ghc-pkg register but it turns out that + -- the same ability is available by using ghc-pkg recache. The recache + -- command is there to support distro package managers that like to work + -- by just installing files and running update commands, rather than + -- special add/remove commands. So the way to register by this method is + -- to write the package registration file directly into the package db and + -- then call hc-pkg recache. + -- + | registerMultiInstance registerOptions + , recacheMultiInstance hpi = + do + let pkgdb = registrationPackageDB packagedbs + writeRegistrationFileDirectly verbosity hpi mbWorkDir pkgdb pkgInfo + recache hpi verbosity mbWorkDir pkgdb + | otherwise = + runProgramInvocation + verbosity + (registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions) + +writeRegistrationFileDirectly + :: Verbosity + -> HcPkgInfo + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBS from + -> InstalledPackageInfo + -> IO () +writeRegistrationFileDirectly verbosity hpi mbWorkDir (SpecificPackageDB dir) pkgInfo + | supportsDirDbs hpi = + do + let pkgfile = interpretSymbolicPath mbWorkDir dir prettyShow (installedUnitId pkgInfo) <.> "conf" + writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) + | otherwise = + dieWithException verbosity NoSupportDirStylePackageDb +writeRegistrationFileDirectly verbosity _ _ _ _ = + -- We don't know here what the dir for the global or user dbs are, + -- if that's needed it'll require a bit more plumbing to support. + dieWithException verbosity OnlySupportSpecificPackageDb + +-- | Call @hc-pkg@ to unregister a package +-- +-- > hc-pkg unregister [pkgid] [--user | --global | --package-db] +unregister :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO () +unregister hpi verbosity mbWorkDir packagedb pkgid = + runProgramInvocation + verbosity + (unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid) + +-- | Call @hc-pkg@ to recache the registered packages. +-- +-- > hc-pkg recache [--user | --global | --package-db] +recache :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO () +recache hpi verbosity mbWorkDir packagedb = + runProgramInvocation + verbosity + (recacheInvocation hpi verbosity mbWorkDir packagedb) + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-db] +expose + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> IO () +expose hpi verbosity mbWorkDir packagedb pkgid = + runProgramInvocation + verbosity + (exposeInvocation hpi verbosity mbWorkDir packagedb pkgid) + +-- | Call @hc-pkg@ to retrieve a specific package +-- +-- > hc-pkg describe [pkgid] [--user | --global | --package-db] +describe + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> PackageId + -> IO [InstalledPackageInfo] +describe hpi verbosity mbWorkDir packagedb pid = do + output <- + getProgramInvocationLBS + verbosity + (describeInvocation hpi verbosity mbWorkDir packagedb pid) + `catchIO` \_ -> return mempty + + case parsePackages output of + Left ok -> return ok + _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid + +-- | Call @hc-pkg@ to hide a package. +-- +-- > hc-pkg hide [pkgid] [--user | --global | --package-db] +hide + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> IO () +hide hpi verbosity mbWorkDir packagedb pkgid = + runProgramInvocation + verbosity + (hideInvocation hpi verbosity mbWorkDir packagedb pkgid) + +-- | Call @hc-pkg@ to get all the details of all the packages in the given +-- package database. +dump + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> IO [InstalledPackageInfo] +dump hpi verbosity mbWorkDir packagedb = do + output <- + getProgramInvocationLBS + verbosity + (dumpInvocation hpi verbosity mbWorkDir packagedb) + `catchIO` \e -> + dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e) + + case parsePackages output of + Left ok -> return ok + _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi)) + +parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] +parsePackages lbs0 = + case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of + Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok] + Left msgs -> Right (NE.toList msgs) + where + splitPkgs :: LBS.ByteString -> [BS.ByteString] + splitPkgs = checkEmpty . doSplit + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | BS.all isSpace8 s = [] + checkEmpty ss = ss + + isSpace8 :: Word8 -> Bool + isSpace8 9 = True -- '\t' + isSpace8 10 = True -- '\n' + isSpace8 13 = True -- '\r' + isSpace8 32 = True -- ' ' + isSpace8 _ = False + + doSplit :: LBS.ByteString -> [BS.ByteString] + doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) + where + go :: [Int64] -> [BS.ByteString] + go [] = [LBS.toStrict lbs] + go (idx : idxs) = + let (pfx, sfx) = LBS.splitAt idx lbs + in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + Just sfx' -> LBS.toStrict pfx : doSplit sfx' + Nothing -> go idxs + + separators :: [LBS.ByteString] + separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] + +lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString +#if MIN_VERSION_bytestring(0,10,8) +lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs +#else +lbsStripPrefix pfx lbs + | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs) + | otherwise = Nothing +#endif + +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo + { importDirs = mungePaths (importDirs pkginfo) + , includeDirs = mungePaths (includeDirs pkginfo) + , libraryDirs = mungePaths (libraryDirs pkginfo) + , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo) + , libraryDynDirs = mungePaths (libraryDynDirs pkginfo) + , frameworkDirs = mungePaths (frameworkDirs pkginfo) + , haddockInterfaces = mungePaths (haddockInterfaces pkginfo) + , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = + "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root : path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> Nothing + +-- Older installed package info files did not have the installedUnitId +-- field, so if it is missing then we fill it as the source package ID. +-- NB: Internal libraries not supported. +setUnitId :: InstalledPackageInfo -> InstalledPackageInfo +setUnitId + pkginfo@InstalledPackageInfo + { installedUnitId = uid + , sourcePackageId = pid + } + | unUnitId uid == "" = + pkginfo + { installedUnitId = mkLegacyUnitId pid + , installedComponentId_ = mkComponentId (prettyShow pid) + } +setUnitId pkginfo = pkginfo + +-- | Call @hc-pkg@ to get the source package Id of all the packages in the +-- given package database. +-- +-- This is much less information than with 'dump', but also rather quicker. +-- Note in particular that it does not include the 'UnitId', just +-- the source 'PackageId' which is not necessarily unique in any package db. +list + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> IO [PackageId] +list hpi verbosity mbWorkDir packagedb = do + output <- + getProgramInvocationOutput + verbosity + (listInvocation hpi verbosity mbWorkDir packagedb) + `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi)) + + case parsePackageIds output of + Just ok -> return ok + _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi)) + where + parsePackageIds = traverse simpleParsec . words + +-------------------------- +-- The program invocations +-- + +initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation +initInvocation hpi verbosity path = + programInvocation (hcPkgProgram hpi) args + where + args = + ["init", path] + ++ verbosityOpts hpi verbosity + +registerInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> RegisterOptions + -> ProgramInvocation +registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions = + (programInvocationCwd mbWorkDir (hcPkgProgram hpi) (args "-")) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo + , progInvokeInputEncoding = IOEncodingUTF8 + } + where + cmdname + | registerAllowOverwrite registerOptions = "update" + | registerMultiInstance registerOptions = "update" + | otherwise = "register" + + args file = + [cmdname, file] + ++ packageDbStackOpts hpi packagedbs + ++ [ "--enable-multi-instance" + | registerMultiInstance registerOptions + ] + ++ [ "--force-files" + | registerSuppressFilesCheck registerOptions + ] + ++ verbosityOpts hpi verbosity + +unregisterInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> ProgramInvocation +unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + +recacheInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBS from + -> ProgramInvocation +recacheInvocation hpi verbosity mbWorkDir packagedb = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["recache", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi verbosity + +exposeInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> ProgramInvocation +exposeInvocation hpi verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + +describeInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> PackageId + -> ProgramInvocation +describeInvocation hpi verbosity mbWorkDir packagedbs pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["describe", prettyShow pkgid] + ++ packageDbStackOpts hpi packagedbs + ++ verbosityOpts hpi verbosity + +hideInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> ProgramInvocation +hideInvocation hpi verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity + +dumpInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> ProgramInvocation +dumpInvocation hpi _verbosity mbWorkDir packagedb = + (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = + ["dump", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi silent + +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. + +listInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> ProgramInvocation +listInvocation hpi _verbosity mbWorkDir packagedb = + (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = + ["list", "--simple-output", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi silent + +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. + +packageDbStackOpts :: HcPkgInfo -> PackageDBStackS from -> [String] +packageDbStackOpts hpi dbstack + | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] + | otherwise = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> + "--global" + : "--user" + : map specific dbs + (GlobalPackageDB : dbs) -> + "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +packageDbFlag :: HcPkgInfo -> String +packageDbFlag hpi + | flagPackageConf hpi = + "package-conf" + | otherwise = + "package-db" + +packageDbOpts :: HcPkgInfo -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> String +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" +packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db + +verbosityOpts :: HcPkgInfo -> Verbosity -> [String] +verbosityOpts hpi v + | noVerboseFlag hpi = + [] + | v >= deafening = ["-v2"] + | v == silent = ["-v0"] + | otherwise = [] diff --git a/src/Distribution/Simple/Program/Hpc.hs b/src/Distribution/Simple/Program/Hpc.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Hpc.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hpc@ program. +module Distribution.Simple.Program.Hpc + ( markup + , union + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName +import Distribution.Pretty +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version + +-- | Invoke hpc with the given parameters. +-- +-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle +-- multiple .mix paths correctly, so we print a warning, and only pass it the +-- first path in the list. This means that e.g. test suites that import their +-- library as a dependency can still work, but those that include the library +-- modules directly (in other-modules) don't. +markup + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> Version + -> Verbosity + -> SymbolicPath Pkg File + -- ^ Path to .tix file + -> [SymbolicPath Pkg (Dir Mix)] + -- ^ Paths to .mix file directories + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Path where html output should be located + -> [ModuleName] + -- ^ List of modules to include in the report + -> IO () +markup mbWorkDir hpc hpcVer verbosity tixFile hpcDirs destDir included = do + hpcDirs' <- + if withinRange hpcVer (orLaterVersion version07) + then return hpcDirs + else do + warn verbosity $ + "Your version of HPC (" + ++ prettyShow hpcVer + ++ ") does not properly handle multiple search paths. " + ++ "Coverage report generation may fail unexpectedly. These " + ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " + ++ "later)." + ++ if null droppedDirs + then "" + else + " The following search paths have been abandoned: " + ++ show droppedDirs + return passedDirs + + -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. + hpcDirs'' <- traverse (tryMakeRelative mbWorkDir) hpcDirs' + + runProgramInvocation + verbosity + (markupInvocation mbWorkDir hpc tixFile hpcDirs'' destDir included) + where + version07 = mkVersion [0, 7] + (passedDirs, droppedDirs) = splitAt 1 hpcDirs + +markupInvocation + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> SymbolicPath Pkg File + -- ^ Path to .tix file + -> [SymbolicPath Pkg (Dir Mix)] + -- ^ Paths to .mix file directories + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Path where html output should be + -- located + -> [ModuleName] + -- ^ List of modules to include + -> ProgramInvocation +markupInvocation mbWorkDir hpc tixFile hpcDirs destDir included = + let args = + [ "markup" + , getSymbolicPath tixFile + , "--destdir=" ++ getSymbolicPath destDir + ] + ++ map (("--hpcdir=" ++) . getSymbolicPath) hpcDirs + ++ [ "--include=" ++ prettyShow moduleName + | moduleName <- included + ] + in programInvocationCwd mbWorkDir hpc args + +union + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> Verbosity + -> [SymbolicPath Pkg File] + -- ^ Paths to .tix files + -> SymbolicPath Pkg File + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> IO () +union mbWorkDir hpc verbosity tixFiles outFile excluded = + runProgramInvocation + verbosity + (unionInvocation mbWorkDir hpc tixFiles outFile excluded) + +unionInvocation + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> [SymbolicPath Pkg File] + -- ^ Paths to .tix files + -> SymbolicPath Pkg File + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> ProgramInvocation +unionInvocation mbWorkDir hpc tixFiles outFile excluded = + programInvocationCwd mbWorkDir hpc $ + concat + [ ["sum", "--union"] + , map getSymbolicPath tixFiles + , ["--output=" ++ getSymbolicPath outFile] + , [ "--exclude=" ++ prettyShow moduleName + | moduleName <- excluded + ] + ] diff --git a/src/Distribution/Simple/Program/Internal.hs b/src/Distribution/Simple/Program/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Internal.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Internal +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Internal utilities used by Distribution.Simple.Program.*. +module Distribution.Simple.Program.Internal + ( stripExtractVersion + ) where + +import Distribution.Compat.Prelude +import Distribution.Utils.Generic (safeTail) +import Prelude () + +-- | Extract the version number from the output of 'strip --version'. +-- +-- Invoking "strip --version" gives very inconsistent results. We +-- ignore everything in parentheses (see #2497), look for the first +-- word that starts with a number, and try parsing out the first two +-- components of it. Non-GNU, non-LLVM 'strip' doesn't appear to have +-- a version flag. +stripExtractVersion :: String -> String +stripExtractVersion str = + let numeric "" = False + numeric (x : _) = isDigit x + + closingParentheses = + [ ")" + , -- LLVM strip outputs "llvm-strip, compatible with GNU strip\nLLVM (http://llvm.org/):\n..." + "):" + ] + + -- Filter out everything in parentheses. + filterPar' :: Int -> [String] -> [String] + filterPar' _ [] = [] + filterPar' n (x : xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs) + | n > 0 && any (`isSuffixOf` x) closingParentheses = filterPar' (n - 1) xs + | n > 0 = filterPar' n xs + | otherwise = x : filterPar' n xs + + filterPar = filterPar' 0 + in case dropWhile (not . numeric) (filterPar . words $ str) of + (ver : _) -> + -- take the first two version components + let isDot = (== '.') + (major, rest) = break isDot ver + minor = takeWhile isDigit (dropWhile isDot rest) + in major ++ "." ++ minor + _ -> "" diff --git a/src/Distribution/Simple/Program/Ld.hs b/src/Distribution/Simple/Program/Ld.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Ld.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Ld +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ld@ linker program. +module Distribution.Simple.Program.Ld + ( combineObjectFiles + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Compiler (arResponseFilesSupported) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile + ) +import Distribution.Simple.Program.Run + ( ProgramInvocation + , multiStageProgramInvocation + , programInvocationCwd + , runProgramInvocation + ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram (..) + ) +import Distribution.Simple.Setup.Config + ( configUseResponseFiles + ) +import Distribution.Simple.Utils + ( defaultTempFileOptions + ) +import Distribution.Utils.Path +import Distribution.Verbosity + ( Verbosity + ) + +import System.Directory + ( renameFile + ) + +-- | Call @ld -r@ to link a bunch of object files together. +combineObjectFiles + :: Verbosity + -> LocalBuildInfo + -> ConfiguredProgram + -> SymbolicPath Pkg File + -> [SymbolicPath Pkg File] + -> IO () +combineObjectFiles verbosity lbi ldProg target files = do + -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, + -- if we have more object files than fit on a single command line then we + -- have a slight problem. What we have to do is link files in batches into + -- a temp object file and then include that one in the next batch. + + let + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + i = interpretSymbolicPath mbWorkDir + mbWorkDir = mbWorkDirLBI lbi + + simpleArgs = ["-r", "-o", u target] + initialArgs = ["-r", "-o", u target] + middleArgs = ["-r", "-o", u target, u tmpfile] + finalArgs = middleArgs + + ld = programInvocationCwd (mbWorkDirLBI lbi) ldProg + simple = ld simpleArgs + initial = ld initialArgs + middle = ld middleArgs + final = ld finalArgs + + invokeWithResponseFile :: FilePath -> ProgramInvocation + invokeWithResponseFile atFile = + ld $ simpleArgs ++ ['@' : atFile] + + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + -- Whether ghc's ar supports response files is a good proxy for + -- whether ghc's ld supports them as well. + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + + run :: [ProgramInvocation] -> IO () + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv : invs) = do + runProgramInvocation verbosity inv + renameFile (i target) (i tmpfile) + run invs + + if oldVersionManualOverride || responseArgumentsNotSupported + then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files) + else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $ + \path -> runProgramInvocation verbosity $ invokeWithResponseFile path + where + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file diff --git a/src/Distribution/Simple/Program/ResponseFile.hs b/src/Distribution/Simple/Program/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/ResponseFile.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.ResponseFile +-- Copyright : (c) Sergey Vinokurov 2017 +-- License : BSD3-style +-- +-- Maintainer : cabal-devel@haskell.org +-- Created : 23 July 2017 +module Distribution.Simple.Program.ResponseFile (withResponseFile) where + +import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) +import Prelude () + +import Distribution.Compat.Prelude +import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) +import Distribution.Utils.Path +import Distribution.Verbosity + +withResponseFile + :: Verbosity + -> TempFileOptions + -> String + -- ^ Template for response file name. + -> Maybe TextEncoding + -- ^ Encoding to use for response file contents. + -> [String] + -- ^ Arguments to put into response file. + -> (FilePath -> IO a) + -> IO a +withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = + withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do + let responseFileName = getSymbolicPath responsePath + traverse_ (hSetEncoding hf) encoding + let responseContents = + unlines $ + map escapeResponseFileArg $ + arguments + hPutStr hf responseContents + hClose hf + debug verbosity $ responseFileName ++ " contents: <<<" + debug verbosity responseContents + debug verbosity $ ">>> " ++ responseFileName + f responseFileName + +-- Support a gcc-like response file syntax. Each separate +-- argument and its possible parameter(s), will be separated in the +-- response file by an actual newline; all other whitespace, +-- single quotes, double quotes, and the character used for escaping +-- (backslash) are escaped. The called program will need to do a similar +-- inverse operation to de-escape and re-constitute the argument list. +escapeResponseFileArg :: String -> String +escapeResponseFileArg = reverse . foldl' escape [] + where + escape :: String -> Char -> String + escape cs c = + case c of + '\\' -> c : '\\' : cs + '\'' -> c : '\\' : cs + '"' -> c : '\\' : cs + _ + | isSpace c -> c : '\\' : cs + | otherwise -> c : cs diff --git a/src/Distribution/Simple/Program/Run.hs b/src/Distribution/Simple/Program/Run.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Run.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Run +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides a data type for program invocations and functions to +-- run them. +module Distribution.Simple.Program.Run + ( ProgramInvocation (..) + , IOEncoding (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , programInvocationCwd + , multiStageProgramInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS + , getProgramInvocationOutputAndErrors + , getProgramInvocationLBSAndErrors + , getEffectiveEnvironment + , getFullEnvironment + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.Environment +import Distribution.Simple.Errors +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils +import Distribution.Utils.Generic +import Distribution.Utils.Path +import Distribution.Verbosity + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map + +-- | Represents a specific invocation of a specific program. +-- +-- This is used as an intermediate type between deciding how to call a program +-- and actually doing it. This provides the opportunity to the caller to +-- adjust how the program will be called. These invocations can either be run +-- directly or turned into shell or batch scripts. +data ProgramInvocation = ProgramInvocation + { progInvokePath :: FilePath + , progInvokeArgs :: [String] + , progInvokeEnv :: [(String, Maybe String)] + , progInvokeCwd :: Maybe FilePath + , progInvokeInput :: Maybe IOData + , progInvokeInputEncoding :: IOEncoding + -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. + , progInvokeOutputEncoding :: IOEncoding + , progInvokeWhen :: IO Bool + } + +data IOEncoding + = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 + +encodeToIOData :: IOEncoding -> IOData -> IOData +encodeToIOData _ iod@(IODataBinary _) = iod +encodeToIOData IOEncodingText iod@(IODataText _) = iod +encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) + +emptyProgramInvocation :: ProgramInvocation +emptyProgramInvocation = + ProgramInvocation + { progInvokePath = "" + , progInvokeArgs = [] + , progInvokeEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + , progInvokeInputEncoding = IOEncodingText + , progInvokeOutputEncoding = IOEncodingText + , progInvokeWhen = pure True + } + +simpleProgramInvocation + :: FilePath + -> [String] + -> ProgramInvocation +simpleProgramInvocation path args = + emptyProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + } + +programInvocation + :: ConfiguredProgram + -> [String] + -> ProgramInvocation +programInvocation prog args = + emptyProgramInvocation + { progInvokePath = programPath prog + , progInvokeArgs = + programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + , progInvokeEnv = programOverrideEnv prog + } + +programInvocationCwd + :: forall to + . Maybe (SymbolicPath CWD (Dir to)) + -> ConfiguredProgram + -> [String] + -> ProgramInvocation +programInvocationCwd mbWorkDir prog args = + (programInvocation prog args) + { progInvokeCwd = fmap getSymbolicPath mbWorkDir + } + +runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + } = + rawSystemExit verbosity Nothing path args +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = Nothing + } = do + menv <- getEffectiveEnvironment envOverrides + maybeExit $ + rawSystemIOWithEnv + verbosity + path + args + mcwd + menv + Nothing + Nothing + Nothing +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = Just inputStr + , progInvokeInputEncoding = encoding + } = do + menv <- getEffectiveEnvironment envOverrides + (_, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + mcwd + menv + (Just input) + IODataModeBinary + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + RunProgramInvocationException path errors + where + input = encodeToIOData encoding inputStr + +getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String +getProgramInvocationOutput verbosity inv = do + (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv + when (exitCode /= ExitSuccess) $ + die' verbosity $ + "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output + +getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString +getProgramInvocationLBS verbosity inv = do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + GetProgramInvocationLBSException (progInvokePath inv) errors + return output + +getProgramInvocationOutputAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (String, String, ExitCode) +getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of + IOEncodingText -> do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText + return (output, errors, exitCode) + IOEncodingUTF8 -> do + (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) + +getProgramInvocationLBSAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (LBS.ByteString, String, ExitCode) +getProgramInvocationLBSAndErrors verbosity inv = + getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + +getProgramInvocationIODataAndErrors + :: KnownIODataMode mode + => Verbosity + -> ProgramInvocation + -> IODataMode mode + -> IO (mode, String, ExitCode) +getProgramInvocationIODataAndErrors + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = minputStr + , progInvokeInputEncoding = encoding + } + mode = do + menv <- getEffectiveEnvironment envOverrides + rawSystemStdInOut verbosity path args mcwd menv input mode + where + input = encodeToIOData encoding <$> minputStr + +-- | Return the current environment extended with the given overrides. +-- If an entry is specified twice in @overrides@, the second entry takes +-- precedence. +-- +-- getEffectiveEnvironment returns 'Nothing' when there are no overrides. +-- It returns an argument that is suitable to pass directly to 'CreateProcess' to +-- override the environment. +-- If you need the full environment to manipulate further, even when there are no overrides, +-- then call 'getFullEnvironment'. +getEffectiveEnvironment + :: [(String, Maybe String)] + -> IO (Maybe [(String, String)]) +getEffectiveEnvironment [] = return Nothing +getEffectiveEnvironment overrides = + fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment + where + apply os env = foldl' (flip update) env os + update (var, Nothing) = Map.delete var + update (var, Just val) = Map.insert var val + +-- | Like 'getEffectiveEnvironment', but when no overrides are specified, +-- returns the full environment instead of 'Nothing'. +getFullEnvironment + :: [(String, Maybe String)] + -> IO [(String, String)] +getFullEnvironment overrides = do + menv <- getEffectiveEnvironment overrides + case menv of + Just env -> return env + Nothing -> getEnvironment + +-- | Like the unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- It takes four template invocations corresponding to the simple, initial, +-- middle and last invocations. If the number of args given is small enough +-- that we can get away with just a single invocation then the simple one is +-- used: +-- +-- > $ simple args +-- +-- If the number of args given means that we need to use multiple invocations +-- then the templates for the initial, middle and last invocations are used: +-- +-- > $ initial args_0 +-- > $ middle args_1 +-- > $ middle args_2 +-- > ... +-- > $ final args_n +multiStageProgramInvocation + :: ProgramInvocation + -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) + -> [String] + -> [ProgramInvocation] +multiStageProgramInvocation simple (initial, middle, final) args = + let argSize inv = + length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + fixedArgSize = maximum (map argSize [simple, initial, middle, final]) + chunkSize = maxCommandLineSize - fixedArgSize + in case splitChunks chunkSize args of + [] -> [simple] + [c] -> [simple `appendArgs` c] + (c : c2 : cs) + | (xs, x) <- unsnocNE (c2 :| cs) -> + [initial `appendArgs` c] + ++ [middle `appendArgs` c' | c' <- xs] + ++ [final `appendArgs` x] + where + appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation + inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as} + + splitChunks :: Int -> [[a]] -> [[[a]]] + splitChunks len = unfoldr $ \s -> + if null s + then Nothing + else Just (chunk len s) + + chunk :: Int -> [[a]] -> ([[a]], [[a]]) + chunk len (s : _) | length s >= len = error toolong + chunk len ss = chunk' [] len ss + + chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) + chunk' acc len (s : ss) + | len' < len = chunk' (s : acc) (len - len' - 1) ss + where + len' = length s + chunk' acc _ ss = (reverse acc, ss) + + toolong = + "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" + +-- FIXME: discover this at configure time or runtime on unix +-- The value is 32k on Windows and posix specifies a minimum of 4k +-- but all sensible unixes use more than 4k. +-- we could use getSysVar ArgumentLimit but that's in the unix lib +-- +maxCommandLineSize :: Int +maxCommandLineSize = 30 * 1024 diff --git a/src/Distribution/Simple/Program/Script.hs b/src/Distribution/Simple/Program/Script.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Script.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Script +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. +module Distribution.Simple.Program.Script + ( invocationAsSystemScript + , invocationAsShellScript + , invocationAsBatchFile + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Program.Run +import Distribution.Simple.Utils +import Distribution.System + +-- | Generate a system script, either POSIX shell script or Windows batch file +-- as appropriate for the given system. +invocationAsSystemScript :: OS -> ProgramInvocation -> String +invocationAsSystemScript Windows = invocationAsBatchFile +invocationAsSystemScript _ = invocationAsShellScript + +-- | Generate a POSIX shell script that invokes a program. +invocationAsShellScript :: ProgramInvocation -> String +invocationAsShellScript + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["#!/bin/sh"] + ++ concatMap setEnv envExtra + ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd] + ++ [ ( case minput of + Nothing -> "" + Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | " + ) + ++ unwords (map quote $ path : args) + ++ " \"$@\"" + ] + where + setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] + setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] + + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'' : cs) = "'\\''" ++ escape cs + escape (c : cs) = c : escape cs + +iodataToText :: IOData -> String +iodataToText (IODataText str) = str +iodataToText (IODataBinary lbs) = fromUTF8LBS lbs + +-- | Generate a Windows batch file that invokes a program. +invocationAsBatchFile :: ProgramInvocation -> String +invocationAsBatchFile + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["@echo off"] + ++ map setEnv envExtra + ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd] + ++ case minput of + Nothing -> + [path ++ concatMap (' ' :) args] + Just input -> + ["("] + ++ ["echo " ++ escape line | line <- lines $ iodataToText input] + ++ [ ") | " + ++ "\"" + ++ path + ++ "\"" + ++ concatMap (\arg -> ' ' : quote arg) args + ] + where + setEnv (var, Nothing) = "set " ++ var ++ "=" + setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val + + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c : cs) = c : escapeQ cs + + escape [] = [] + escape ('|' : cs) = "^|" ++ escape cs + escape ('<' : cs) = "^<" ++ escape cs + escape ('>' : cs) = "^>" ++ escape cs + escape ('&' : cs) = "^&" ++ escape cs + escape ('(' : cs) = "^(" ++ escape cs + escape (')' : cs) = "^)" ++ escape cs + escape ('^' : cs) = "^^" ++ escape cs + escape (c : cs) = c : escape cs diff --git a/src/Distribution/Simple/Program/Strip.hs b/src/Distribution/Simple/Program/Strip.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Strip.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Strip +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @strip@ program. +module Distribution.Simple.Program.Strip (stripLib, stripExe) +where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Verbosity +import Distribution.Version + +import System.FilePath (takeBaseName) + +runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () +runStrip verbosity progDb path args = + case lookupProgram stripProgram progDb of + Just strip -> runProgram verbosity strip (args ++ [path]) + Nothing -> + unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ + "Unable to strip executable or library '" + ++ (takeBaseName path) + ++ "' (missing the 'strip' program)" + +stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () +stripExe verbosity (Platform _arch os) progdb path = + runStrip verbosity progdb path args + where + args = case os of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () +stripLib verbosity (Platform arch os) progdb path = do + case os of + OSX -> + -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or + -- Solaris. See #1630. + return () + IOS -> return () + AIX -> return () + Solaris -> return () + OpenBSD -> + -- '--strip-unneeded' sometimes strips too much on OpenBSD. + -- -- See https://cvsweb.openbsd.org/cgi-bin/cvsweb/~checkout~/ports/lang/ghc/patches/patch-libraries_Cabal_Cabal_Distribution_Simple_Program_Strip_hs + return () + Windows -> + -- Stripping triggers a bug in 'strip.exe' for + -- libraries with lots identically named modules. See + -- #1784. + return () + Linux + | arch == I386 -> + -- Versions of 'strip' on 32-bit Linux older than 2.18 are + -- broken. See #2339. + let okVersion = orLaterVersion (mkVersion [2, 18]) + in case programVersion =<< lookupProgram stripProgram progdb of + Just v + | withinRange v okVersion -> + runStrip verbosity progdb path args + _ -> + warn verbosity $ + "Unable to strip library '" + ++ (takeBaseName path) + ++ "' (version of 'strip' too old; " + ++ "requires >= 2.18 on 32-bit Linux)" + _ -> runStrip verbosity progdb path args + where + args = ["--strip-unneeded"] diff --git a/src/Distribution/Simple/Program/Types.hs b/src/Distribution/Simple/Program/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Program/Types.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There's reasonable default behavior for trying to find +-- \"foo\" in PATH, being able to override its location, etc. +module Distribution.Simple.Program.Types + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) + + -- * Configured program and related functions + , ConfiguredProgram (..) + , programPath + , suppressOverrideArgs + , ProgArg + , ProgramLocation (..) + , simpleConfiguredProgram + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.PackageDescription +import Distribution.Verbosity +import Distribution.Version + +import qualified Data.Map as Map + +-- | Represents a program which can be configured. +-- +-- Note: rather than constructing this directly, start with 'simpleProgram' and +-- override any extra fields. +data Program = Program + { programName :: String + -- ^ The simple name of the program, eg. ghc + , programFindLocation + :: Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + -- ^ A function to search for the program if its location was not + -- specified by the user. Usually this will just be a call to + -- 'findProgramOnSearchPath'. + -- + -- It is supplied with the prevailing search path which will typically + -- just be used as-is, but can be extended or ignored as needed. + -- + -- For the purpose of change monitoring, in addition to the location + -- where the program was found, it returns all the other places that + -- were tried. + , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) + -- ^ Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's OK to return Nothing. + , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + -- ^ A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). For example + -- it could add args, or environment vars. + , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] + -- ^ A function that filters any arguments that don't impact the output + -- from a commandline. Used to limit the volatility of dependency hashes + -- when using new-build. + } + +instance Show Program where + show (Program name _ _ _ _) = "Program: " ++ name + +type ProgArg = String + +-- | A search path to use when locating executables. This is analogous +-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use +-- the system default method for finding executables ('findExecutable' which +-- on unix is simply looking on the @$PATH@ but on win32 is a bit more +-- complicated). +-- +-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs +-- either before, after or instead of the default, e.g. here we add an extra +-- dir to search after the usual ones. +-- +-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] +-- +-- We also use this path to set the environment when running child processes. +-- +-- The @ProgramDb@ is created with a @ProgramSearchPath@ to which we +-- @prependProgramSearchPath@ to add the ones that come from cli flags and from +-- configurations. Then each of the programs that are configured in the db +-- inherits the same path as part of @configureProgram@. +type ProgramSearchPath = [ProgramSearchPathEntry] + +data ProgramSearchPathEntry + = -- | A specific dir + ProgramSearchPathDir FilePath + | -- | The system default + ProgramSearchPathDefault + deriving (Show, Eq, Generic) + +instance Binary ProgramSearchPathEntry +instance Structured ProgramSearchPathEntry + +-- | Represents a program which has been configured and is thus ready to be run. +-- +-- These are usually made by configuring a 'Program', but if you have to +-- construct one directly then start with 'simpleConfiguredProgram' and +-- override any extra fields. +data ConfiguredProgram = ConfiguredProgram + { programId :: String + -- ^ Just the name again + , programVersion :: Maybe Version + -- ^ The version of this program, if it is known. + , programDefaultArgs :: [String] + -- ^ Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + , programOverrideArgs :: [String] + -- ^ Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + , programOverrideEnv :: [(String, Maybe String)] + -- ^ Override environment variables for this program. + -- These env vars will extend\/override the prevailing environment of + -- the current to form the environment for the new process. + , programProperties :: Map.Map String String + -- ^ A key-value map listing various properties of the program, useful + -- for feature detection. Populated during the configuration step, key + -- names depend on the specific program. + , programLocation :: ProgramLocation + -- ^ Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + , programMonitorFiles :: [FilePath] + -- ^ In addition to the 'programLocation' where the program was found, + -- these are additional locations that were looked at. The combination + -- of this found location and these not-found locations can be used to + -- monitor to detect when the re-configuring the program might give a + -- different result (e.g. found in a different location). + } + deriving (Eq, Generic, Read, Show) + +instance Binary ConfiguredProgram +instance Structured ConfiguredProgram + +-- | Where a program was found. Also tells us whether it's specified by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = -- | The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + UserSpecified {locationPath :: FilePath} + | -- | The program was found automatically. + FoundOnSystem {locationPath :: FilePath} + deriving (Eq, Generic, Read, Show) + +instance Binary ProgramLocation +instance Structured ProgramLocation + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Suppress any extra arguments added by the user. +suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram +suppressOverrideArgs prog = prog{programOverrideArgs = []} + +-- | Make a simple 'ConfiguredProgram'. +-- +-- > simpleConfiguredProgram "foo" (FoundOnSystem path) +simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram +simpleConfiguredProgram name loc = + ConfiguredProgram + { programId = name + , programVersion = Nothing + , programDefaultArgs = [] + , programOverrideArgs = [] + , programOverrideEnv = [] + , programProperties = Map.empty + , programLocation = loc + , programMonitorFiles = [] -- did not look in any other locations + } diff --git a/src/Distribution/Simple/Register.hs b/src/Distribution/Simple/Register.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Register.hs @@ -0,0 +1,755 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- popular so we also provide a way to simply generate the package registration +-- file which then must be manually passed to @ghc-pkg@. It is possible to +-- generate registration information for where the package is to be installed, +-- or alternatively to register the package in place in the build tree. The +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- mixes it all in this module, which is rather unsatisfactory. The script +-- generation and the unregister feature are not well used or tested. +module Distribution.Simple.Register + ( register + , unregister + , internalPackageDBPath + , initPackageDB + , doesPackageDBExist + , createPackageDB + , deletePackageDB + , abiHash + , invokeHcPkg + , registerPackage + , HcPkg.RegisterOptions (..) + , HcPkg.defaultRegisterOptions + , generateRegistrationInfo + , inplaceInstalledPackageInfo + , absoluteInstalledPackageInfo + , generalInstalledPackageInfo + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo + +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.LocalBuildInfo + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC + +import Distribution.Backpack.DescribeUnitId +import Distribution.Compat.Graph (IsNode (nodeKey)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (licenseFromSPDX, licenseToSPDX) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.Program +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Program.Script +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Register +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Utils.MapAccum +import Distribution.Utils.Path +import Distribution.Verbosity as Verbosity +import Distribution.Version +import System.Directory +import System.FilePath (isAbsolute) + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +-- ----------------------------------------------------------------------------- +-- Registration + +register + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -- ^ Install in the user's database?; verbose + -> IO () +register pkg_descr lbi0 flags = do + -- Duncan originally asked for us to not register/install files + -- when there was no public library. But with per-component + -- configure, we legitimately need to install internal libraries + -- so that we can get them. So just unconditionally install. + let verbosity = fromFlag $ registerVerbosity flags + targets <- readTargetInfos verbosity pkg_descr lbi0 $ registerTargets flags + + -- It's important to register in build order, because ghc-pkg + -- will complain if a dependency is not registered. + let componentsToRegister = + neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) + + (_, ipi_mbs) <- + mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> + case targetComponent tgt of + CLib lib -> do + let clbi = targetCLBI tgt + lbi = lbi0{installedPkgs = index} + ipi <- generateOne pkg_descr lib lbi clbi flags + return (Index.insert ipi index, Just ipi) + _ -> return (index, Nothing) + + registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) + +generateOne + :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> RegisterFlags + -> IO InstalledPackageInfo +generateOne pkg lib lbi clbi regFlags = + do + absPackageDBs <- absolutePackageDBPaths mbWorkDir packageDbs + installedPkgInfo <- + generateRegistrationInfo + verbosity + pkg + lib + lbi + clbi + inplace + reloc + distPref + (registrationPackageDB absPackageDBs) + info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) + return installedPkgInfo + where + common = registerCommonFlags regFlags + inplace = fromFlag (regInPlace regFlags) + reloc = relocatable lbi + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + +registerAll + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -> [InstalledPackageInfo] + -> IO () +registerAll pkg lbi regFlags ipis = + do + when (fromFlag (regPrintId regFlags)) $ do + for_ ipis $ \installedPkgInfo -> + -- Only print the public library's IPI + when + ( packageId installedPkgInfo == packageId pkg + && IPI.sourceLibName installedPkgInfo == LMainLibName + ) + $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) + + -- Three different modes: + case () of + _ + | modeGenerateRegFile -> writeRegistrationFileOrDirectory + | modeGenerateRegScript -> writeRegisterScript + | otherwise -> do + for_ ipis $ \ipi -> do + setupMessage' + verbosity + "Registering" + (packageId pkg) + (CLibName (IPI.sourceLibName ipi)) + (Just (IPI.instantiatedWith ipi)) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (mbWorkDirLBI lbi) + packageDbs + ipi + HcPkg.defaultRegisterOptions + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = + interpretSymbolicPathLBI lbi $ + fromMaybe + (makeSymbolicPath (prettyShow (packageId pkg) <.> "conf")) + (fromFlag (regGenPkgConf regFlags)) + + modeGenerateRegScript = fromFlag (regGenScript regFlags) + + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + common = registerCommonFlags regFlags + verbosity = fromFlag (setupVerbosity common) + mbWorkDir = mbWorkDirLBI lbi + + writeRegistrationFileOrDirectory = do + -- Handles overwriting both directory and file + deletePackageDB regFile + case ipis of + [installedPkgInfo] -> do + info verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo) + _ -> do + info verbosity ("Creating package registration directory: " ++ regFile) + createDirectory regFile + let num_ipis = length ipis + lpad m xs = replicate (m - length ys) '0' ++ ys + where + ys = take m xs + number i = lpad (length (show num_ipis)) (show i) + for_ (zip ([1 ..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> + writeUTF8File + (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) + (IPI.showInstalledPackageInfo installedPkgInfo) + + writeRegisterScript = + case compilerFlavor (compiler lbi) of + UHC -> notice verbosity "Registration scripts not needed for uhc" + _ -> + withHcPkg + verbosity + "Registration scripts are not implemented for this compiler" + (compiler lbi) + (withPrograms lbi) + (writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs) + +generateRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Bool + -> SymbolicPath Pkg (Dir Dist) + -> PackageDB + -> IO InstalledPackageInfo +generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do + inplaceDir <- absoluteWorkingDirLBI lbi + installedPkgInfo <- + if inplace + then -- NB: With an inplace installation, the user may run './Setup + -- build' to update the library files, without reregistering. + -- In this case, it is critical that the ABI hash not flip. + + return + ( inplaceInstalledPackageInfo + inplaceDir + distPref + pkg + (mkAbiHash "inplace") + lib + lbi + clbi + ) + else do + abi_hash <- abiHash verbosity pkg distPref lbi lib clbi + if reloc + then + relocRegistrationInfo + verbosity + pkg + lib + lbi + clbi + abi_hash + packageDb + else + return + ( absoluteInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + ) + + return installedPkgInfo + +-- | Compute the 'AbiHash' of a library that we built inplace. +abiHash + :: Verbosity + -> PackageDescription + -> SymbolicPath Pkg (Dir Dist) + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO AbiHash +abiHash verbosity pkg distPref lbi lib clbi = + case compilerFlavor comp of + GHC -> do + fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi + GHCJS -> do + fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi + _ -> return (mkAbiHash "") + where + comp = compiler lbi + lbi' = + lbi + { withPackageDB = + withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] + } + +relocRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> AbiHash + -> PackageDB + -> IO InstalledPackageInfo +relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = + case (compilerFlavor (compiler lbi)) of + GHC -> do + fs <- GHC.pkgRoot verbosity lbi packageDb + return + ( relocatableInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + fs + ) + _ -> dieWithException verbosity RelocRegistrationInfo + +initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () +initPackageDB verbosity comp progdb dbPath = + createPackageDB verbosity comp progdb False dbPath + +-- | Create an empty package DB at the specified location. +createPackageDB + :: Verbosity + -> Compiler + -> ProgramDb + -> Bool + -> FilePath + -> IO () +createPackageDB verbosity comp progdb preferCompat dbPath = + case compilerFlavor comp of + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + UHC -> return () + _ -> dieWithException verbosity CreatePackageDB + +doesPackageDBExist :: FilePath -> IO Bool +doesPackageDBExist dbPath = do + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then return True + else doesFileExist dbPath + +deletePackageDB :: FilePath -> IO () +deletePackageDB dbPath = do + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then removeDirectoryRecursive dbPath + else do + file_exists <- doesFileExist dbPath + when file_exists $ removeFile dbPath + +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the +-- provided command-line arguments to it. +invokeHcPkg + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> [String] + -> IO () +invokeHcPkg verbosity comp progdb mbWorkDir dbStack extraArgs = + withHcPkg + verbosity + "invokeHcPkg" + comp + progdb + (\hpi -> HcPkg.invoke hpi verbosity mbWorkDir dbStack extraArgs) + +withHcPkg + :: Verbosity + -> String + -> Compiler + -> ProgramDb + -> (HcPkg.HcPkgInfo -> IO a) + -> IO a +withHcPkg verbosity name comp progdb f = + case compilerFlavor comp of + GHC -> f (GHC.hcPkgInfo progdb) + GHCJS -> f (GHCJS.hcPkgInfo progdb) + _ -> dieWithException verbosity $ WithHcPkg name + +registerPackage + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity comp progdb mbWorkDir packageDbs installedPkgInfo registerOptions = + case compilerFlavor comp of + GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions + GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions + _ + | HcPkg.registerMultiInstance registerOptions -> + dieWithException verbosity RegisMultiplePkgNotSupported + UHC -> UHC.registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo + _ -> dieWithException verbosity RegisteringNotImplemented + +writeHcPkgRegisterScript + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> [InstalledPackageInfo] + -> PackageDBStack + -> HcPkg.HcPkgInfo + -> IO () +writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do + let genScript installedPkgInfo = + let invocation = + HcPkg.registerInvocation + hpi + Verbosity.normal + mbWorkDir + packageDbs + installedPkgInfo + HcPkg.defaultRegisterOptions + in invocationAsSystemScript buildOS invocation + scripts = map genScript ipis + -- TODO: Do something more robust here + regScript = unlines scripts + + let out_file = interpretSymbolicPath mbWorkDir regScriptFileName + info verbosity ("Creating package registration script: " ++ out_file) + writeUTF8File out_file regScript + setFileExecutable out_file + +regScriptFileName :: SymbolicPath Pkg File +regScriptFileName = case buildOS of + Windows -> makeSymbolicPath "register.bat" + _ -> makeSymbolicPath "register.sh" + +-- ----------------------------------------------------------------------------- +-- Making the InstalledPackageInfo + +-- | Construct 'InstalledPackageInfo' for a library in a package, given a set +-- of installation directories. +generalInstalledPackageInfo + :: ([FilePath] -> [FilePath]) + -- ^ Translate relative include dir paths to + -- absolute paths. + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstallDirs FilePath + -> InstalledPackageInfo +generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = + IPI.InstalledPackageInfo + { IPI.sourcePackageId = packageId pkg + , IPI.installedUnitId = componentUnitId clbi + , IPI.installedComponentId_ = componentComponentId clbi + , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi) + , IPI.sourceLibName = libName lib + , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi) + , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license + IPI.license = + if ghc84 + then Left $ either id licenseToSPDX $ licenseRaw pkg + else Right $ either licenseFromSPDX id $ licenseRaw pkg + , IPI.copyright = copyright pkg + , IPI.maintainer = maintainer pkg + , IPI.author = author pkg + , IPI.stability = stability pkg + , IPI.homepage = homepage pkg + , IPI.pkgUrl = pkgUrl pkg + , IPI.synopsis = synopsis pkg + , IPI.description = description pkg + , IPI.category = category pkg + , IPI.abiHash = abi_hash + , IPI.indefinite = componentIsIndefinite clbi + , IPI.exposed = libExposed lib + , IPI.exposedModules = + expectLibraryComponent (maybeComponentExposedModules clbi) + -- add virtual modules into the list of exposed modules for the + -- package database as well. + ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi) + , IPI.hiddenModules = otherModules bi + , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo + , IPI.importDirs = [libdir installDirs | hasModules] + , IPI.libraryDirs = libdirs + , IPI.libraryDirsStatic = libdirsStatic + , IPI.libraryDynDirs = dynlibdirs + , IPI.dataDir = datadir installDirs + , IPI.hsLibraries = + ( if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else [] + ) + ++ extraBundledLibs bi + , IPI.extraLibraries = extraLibs bi + , IPI.extraLibrariesStatic = extraLibsStatic bi + , IPI.extraGHCiLibraries = extraGHCiLibs bi + , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc + , IPI.includes = map getSymbolicPath $ includes bi + , IPI.depends = depends + , IPI.abiDepends = [] -- due to #5465 + , IPI.ccOptions = [] -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + , IPI.cxxOptions = [] -- Also. NOT cxxOptions bi! + , IPI.ldOptions = ldOptions bi + , IPI.frameworks = map getSymbolicPath $ frameworks bi + , IPI.frameworkDirs = map getSymbolicPath $ extraFrameworkDirs bi + , IPI.haddockInterfaces = [haddockdir installDirs haddockLibraryPath pkg lib | hasModules] + , IPI.haddockHTMLs = [htmldir installDirs | hasModules] + , IPI.pkgRoot = Nothing + , IPI.libVisibility = libVisibility lib + } + where + ghc84 = case compilerId $ compiler lbi of + CompilerId GHC v -> v >= mkVersion [8, 4] + _ -> False + + bi = libBuildInfo lib + -- TODO: unclear what the root cause of the + -- duplication is, but we nub it here for now: + depends = ordNub $ map fst (componentPackageDeps clbi) + (absinc, relinc) = partition isAbsolute (map getSymbolicPath $ includeDirs bi) + hasModules = not $ null (allLibModules lib clbi) + comp = compiler lbi + hasLibrary = + ( hasModules + || not (null (cSources bi)) + || not (null (asmSources bi)) + || not (null (cmmSources bi)) + || not (null (cxxSources bi)) + || (not (null (jsSources bi)) && hasJsSupport) + ) + && not (componentIsIndefinite clbi) + hasJsSupport = case hostPlatform lbi of + Platform JavaScript _ -> True + _ -> False + extraLibDirs' = map getSymbolicPath $ extraLibDirs bi + libdirsStatic + | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback + | otherwise = extraLibDirsStaticOrFallback + where + -- If no static library dirs were given, the package likely makes no + -- distinction between fully static linking and otherwise. + -- Fall back to the normal library dirs in that case. + extraLibDirsStaticOrFallback = case extraLibDirsStatic bi of + [] -> extraLibDirs' + dirs -> map getSymbolicPath dirs + (libdirs, dynlibdirs) + | not hasLibrary = + (extraLibDirs', []) + -- the dynamic-library-dirs defaults to the library-dirs if not specified, + -- so this works whether the dynamic-library-dirs field is supported or not + + | libraryDynDirSupported comp = + ( libdir installDirs : extraLibDirs' + , dynlibdir installDirs : extraLibDirs' + ) + | otherwise = + (libdir installDirs : dynlibdir installDirs : extraLibDirs', []) + expectLibraryComponent (Just attribute) = attribute + expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.") + +-- the compiler doesn't understand the dynamic-library-dirs field so we +-- add the dyn directory to the "normal" list in the library-dirs field + +-- | Construct 'InstalledPackageInfo' for a library that is in place in the +-- build tree. +-- +-- This function knows about the layout of in place packages. +inplaceInstalledPackageInfo + :: AbsolutePath (Dir Pkg) + -> SymbolicPath Pkg (Dir Dist) + -- ^ location of the dist tree + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = + generalInstalledPackageInfo + adjustRelativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs + where + i = interpretSymbolicPathAbsolute inplaceDir -- See Note [Symbolic paths] in Distribution.Utils.Path + adjustRelativeIncludeDirs = concatMap $ \d -> + [ i $ makeRelativePathEx d -- local include-dir + , i $ libTargetDir makeRelativePathEx d -- autogen include-dir + ] + libTargetDir = componentBuildDir lbi clbi + installDirs = + (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) + { libdir = i libTargetDir + , dynlibdir = i libTargetDir + , datadir = + let rawDataDir = dataDir pkg + in if null $ getSymbolicPath rawDataDir + then i sameDirectory + else i rawDataDir + , docdir = i inplaceDocdir + , htmldir = inplaceHtmldir + , haddockdir = inplaceHtmldir + } + inplaceDocdir = distPref makeRelativePathEx "doc" + inplaceHtmldir = i $ inplaceDocdir makeRelativePathEx ("html" prettyShow (packageName pkg)) + +-- | Construct 'InstalledPackageInfo' for the final install location of a +-- library package. +-- +-- This function knows about the layout of installed packages. +absoluteInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs + where + -- For installed packages we install all include files into one dir, + -- whereas in the build tree they may live in multiple local dirs. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + +relocatableInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath CWD ('Dir Pkg) + -> InstalledPackageInfo +relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs + where + -- For installed packages we install all include files into one dir, + -- whereas in the build tree they may live in multiple local dirs. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + + installDirs = + fmap (("${pkgroot}" ) . shortRelativePath (getSymbolicPath pkgroot)) $ + absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + +-- ----------------------------------------------------------------------------- +-- Unregistration + +unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregister pkg lbi regFlags = do + let pkgid = packageId pkg + common = registerCommonFlags regFlags + genScript = fromFlag (regGenScript regFlags) + verbosity = fromFlag (setupVerbosity common) + packageDb = + fromFlagOrDefault + (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + mbWorkDir = mbWorkDirLBI lbi + unreg hpi = + let invocation = + HcPkg.unregisterInvocation + hpi + Verbosity.normal + mbWorkDir + packageDb + pkgid + in if genScript + then + writeFileAtomic + unregScriptFileName + (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation + setupMessage verbosity "Unregistering" pkgid + withHcPkg + verbosity + "unregistering is only implemented for GHC and GHCJS" + (compiler lbi) + (withPrograms lbi) + unreg + +unregScriptFileName :: FilePath +unregScriptFileName = case buildOS of + Windows -> "unregister.bat" + _ -> "unregister.sh" + +internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB) +internalPackageDBPath lbi distPref = + case compilerFlavor (compiler lbi) of + UHC -> UHC.inplacePackageDbPath lbi + _ -> distPref makeRelativePathEx "package.conf.inplace" diff --git a/src/Distribution/Simple/Setup.hs b/src/Distribution/Simple/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/ShowBuildInfo.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- This module defines a simple JSON-based format for exporting basic +-- information about a Cabal package and the compiler configuration Cabal +-- would use to build it. This can be produced with the +-- @cabal build --enable-build-info@ command. +-- +-- +-- This format is intended for consumption by external tooling and should +-- therefore be rather stable. Moreover, this allows tooling users to avoid +-- linking against Cabal. This is an important advantage as direct API usage +-- tends to be rather fragile in the presence of user-initiated upgrades of +-- Cabal. +-- +-- Below is an example of the output this module produces, +-- +-- @ +-- { "cabal-lib-version": "1.23.0.0", +-- "compiler": { +-- "flavour": "GHC", +-- "compiler-id": "ghc-7.10.2", +-- "path": "/usr/bin/ghc", +-- }, +-- "components": [ +-- { "type": "lib", +-- "name": "lib:Cabal", +-- "compiler-args": +-- ["-O", "-XHaskell98", "-Wall", +-- "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"] +-- "modules": ["Project.ModA", "Project.ModB", "Paths_project"], +-- "src-files": [], +-- "src-dirs": ["src"] +-- } +-- ] +-- } +-- @ +-- +-- The output format needs to be validated against 'doc/json-schemas/build-info.schema.json'. +-- If the format changes, update the schema as well! +-- +-- The @cabal-lib-version@ property provides the version of the Cabal library +-- which generated the output. The @compiler@ property gives some basic +-- information about the compiler Cabal would use to compile the package. +-- +-- The @components@ property gives a list of the Cabal 'Component's defined by +-- the package. Each has, +-- +-- * @type@: the type of the component (one of @lib@, @exe@, +-- @test@, @bench@, or @flib@) +-- * @name@: a string serving to uniquely identify the component within the +-- package. +-- * @compiler-args@: the command-line arguments Cabal would pass to the +-- compiler to compile the component +-- * @modules@: the modules belonging to the component +-- * @src-dirs@: a list of directories where the modules might be found +-- * @src-files@: any other Haskell sources needed by the component +-- +-- Note: At the moment this is only supported when using the GHC compiler. +module Distribution.Simple.ShowBuildInfo + ( mkBuildInfo + , mkBuildInfo' + , mkCompilerInfo + , mkComponentInfo + ) where + +import System.FilePath + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.Program.GHC as GHC + +import Distribution.Compiler +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Setup.Build (BuildFlags) +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Text +import Distribution.Types.TargetInfo +import Distribution.Utils.Json +import Distribution.Utils.Path +import Distribution.Verbosity + +-- | Construct a JSON document describing the build information for a +-- package. +mkBuildInfo + :: AbsolutePath (Dir Pkg) + -- ^ The source directory of the package + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> (ConfiguredProgram, Compiler) + -- ^ Compiler information. + -- Needs to be passed explicitly, as we can't extract that information here + -- without some partial function. + -> [TargetInfo] + -> ([String], Json) + -- ^ Json representation of buildinfo alongside generated warnings +mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields) + where + buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos + componentInfosWithWarnings = map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild + componentInfos = map snd componentInfosWithWarnings + warnings = concatMap fst componentInfosWithWarnings + +-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and +-- 'mkComponentInfo' yourself. +-- +-- If you change the format or any name in the output json, don't forget to update +-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of +-- @--enable-build-info@\/@--disable-build-info@. +mkBuildInfo' + :: Json + -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] + -- ^ The 'Json' from 'mkComponentInfo' + -> [(String, Json)] +mkBuildInfo' compilerInfo componentInfos = + [ "cabal-lib-version" .= JsonString (display cabalVersion) + , "compiler" .= compilerInfo + , "components" .= JsonArray componentInfos + ] + +mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json +mkCompilerInfo compilerProgram compilerInfo = + JsonObject + [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) + , "compiler-id" .= JsonString (showCompilerId compilerInfo) + , "path" .= JsonString (programPath compilerProgram) + ] + +mkComponentInfo :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) +mkComponentInfo wdir pkg_descr lbi clbi = + ( warnings + , JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString compilerArgs) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map (JsonString . getSymbolicPath) sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) + , "src-dir" .= JsonString (addTrailingPathSeparator (getAbsolutePath wdir)) + ] + <> cabalFile + ) + where + (warnings, compilerArgs) = getCompilerArgs bi lbi clbi + name = componentLocalName clbi + bi = componentBuildInfo comp + -- If this error happens, a cabal invariant has been violated + comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" + CBench _ -> "bench" + CFLib _ -> "flib" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + CTest test -> + case testInterface test of + TestSuiteExeV10 _ _ -> [] + TestSuiteLibV09 _ modName -> [modName] + TestSuiteUnsupported _ -> [] + CBench bench -> benchmarkModules bench + CFLib flib -> foreignLibModules flib + sourceFiles = case comp of + CLib _ -> [] + CExe exe -> [modulePath exe] + CTest test -> + case testInterface test of + TestSuiteExeV10 _ fp -> [fp] + TestSuiteLibV09 _ _ -> [] + TestSuiteUnsupported _ -> [] + CBench bench -> case benchmarkInterface bench of + BenchmarkExeV10 _ fp -> [fp] + BenchmarkUnsupported _ -> [] + CFLib _ -> [] + cabalFile + | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString $ getSymbolicPath fp)] + | otherwise = [] + +-- | Get the command-line arguments that would be passed +-- to the compiler to build the given component. +getCompilerArgs + :: BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> ([String], [String]) +getCompilerArgs bi lbi clbi = + case compilerFlavor $ compiler lbi of + GHC -> ([], ghcArgs) + GHCJS -> ([], ghcArgs) + c -> + ( + [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build " + ++ " arguments for compiler " + ++ show c + ] + , [] + ) + where + -- This is absolutely awful + ghcArgs = + GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts + baseOpts = + GHC.componentGhcOptions normal lbi bi clbi $ + buildDir lbi diff --git a/src/Distribution/Simple/SrcDist.hs b/src/Distribution/Simple/SrcDist.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/SrcDist.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. +-- The 'sdist' action now also does some distribution QA checks. +module Distribution.Simple.SrcDist + ( -- * The top level action + sdist + + -- ** Parts of 'sdist' + , printPackageProblems + , prepareTree + , createArchive + + -- ** Snapshots + , prepareSnapshotTree + , snapshotPackage + , snapshotVersion + , dateToSnapshotNumber + + -- * Extracting the source files + , listPackageSources + , listPackageSourcesWithDie + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Configure (findDistPrefOrDefault) +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.Glob (matchDirFileGlobWithDie) +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.SDist +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version + +import qualified Data.Map as Map +import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) +import System.Directory (doesFileExist) +import System.IO (IOMode (WriteMode), hPutStrLn, withFile) + +-- | Create a source distribution. +sdist + :: PackageDescription + -- ^ information from the tarball + -> SDistFlags + -- ^ verbosity & snapshot + -> (FilePath -> FilePath) + -- ^ build prefix (temp dir) + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () +sdist pkg flags mkTmpDir pps = do + distPref <- findDistPrefOrDefault $ setupDistPref common + let targetPref = i distPref + tmpTargetDir = mkTmpDir (i distPref) + + -- When given --list-sources, just output the list of sources to a file. + case sDistListSources flags of + Flag path -> withFile path WriteMode $ \outHandle -> do + ordinary <- listPackageSources verbosity mbWorkDir pkg pps + traverse_ (hPutStrLn outHandle . getSymbolicPath) ordinary + notice verbosity $ "List of package sources written to file '" ++ path ++ "'" + NoFlag -> do + -- do some QA + printPackageProblems verbosity pkg + + date <- getCurrentTime + let pkg' + | snapshot = snapshotPackage date pkg + | otherwise = pkg + + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + info verbosity $ "Source directory created: " ++ targetDir + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile + where + generateSourceDir :: FilePath -> PackageDescription -> IO () + generateSourceDir targetDir pkg' = do + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity mbWorkDir pkg' targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + + common = sDistCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + snapshot = fromFlag (sDistSnapshot flags) + +-- | List all source files of a package. +-- +-- Since @Cabal-3.4@ returns a single list. There shouldn't be any +-- executable files, they are hardly portable. +listPackageSources + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [SymbolicPath Pkg File] +listPackageSources verbosity cwd pkg_descr0 pps = do + -- Call helpers that actually do all work. + listPackageSources' verbosity dieWithException cwd pkg_descr pps + where + pkg_descr = filterAutogenModules pkg_descr0 + +-- | A variant of 'listPackageSources' with configurable 'die'. +-- +-- /Note:/ may still 'die' directly. For example on missing include file. +-- +-- Since @3.4.0.0 +listPackageSourcesWithDie + :: Verbosity + -- ^ verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [SymbolicPath Pkg File] +listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do + -- Call helpers that actually do all work. + listPackageSources' verbosity rip cwd pkg_descr pps + where + pkg_descr = filterAutogenModules pkg_descr0 + +listPackageSources' + :: Verbosity + -- ^ verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [SymbolicPath Pkg File] +listPackageSources' verbosity rip mbWorkDir pkg_descr pps = + fmap concat . sequenceA $ + [ -- Library sources. + fmap concat + . withAllLib + $ \Library + { exposedModules = modules + , signatures = sigs + , libBuildInfo = libBi + } -> + allSourcesBuildInfo verbosity rip mbWorkDir libBi pps (modules ++ sigs) + , -- Executables sources. + fmap concat + . withAllExe + $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir exeBi pps [] + mainSrc <- findMainExeFile verbosity mbWorkDir exeBi pps mainPath + return (mainSrc : biSrcs) + , -- Foreign library sources + fmap concat + . withAllFLib + $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir flibBi pps [] + defFiles <- + traverse + (findModDefFile verbosity mbWorkDir flibBi pps) + (foreignLibModDefFile flib) + return (defFiles ++ biSrcs) + , -- Test suites sources. + fmap concat + . withAllTest + $ \t -> do + let bi = testBuildInfo t + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps [] + srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath + return (srcMainFile : biSrcs) + TestSuiteLibV09 _ m -> + allSourcesBuildInfo verbosity rip mbWorkDir bi pps [m] + TestSuiteUnsupported tp -> + rip verbosity $ UnsupportedTestSuite (show tp) + , -- Benchmarks sources. + fmap concat + . withAllBenchmark + $ \bm -> do + let bi = benchmarkBuildInfo bm + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps [] + srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath + return (srcMainFile : biSrcs) + BenchmarkUnsupported tp -> + rip verbosity $ UnsupportedBenchMark (show tp) + , -- Data files. + fmap concat + . for (dataFiles pkg_descr) + $ \filename -> + do + let srcDataDirRaw = dataDir pkg_descr + srcDataFile :: SymbolicPath Pkg File + srcDataFile + | null (getSymbolicPath srcDataDirRaw) = sameDirectory filename + | otherwise = srcDataDirRaw filename + fmap coerceSymbolicPath + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir srcDataFile + , -- Extra source files. + fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> + fmap relativeSymbolicPath + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath + , -- Extra doc files. + fmap concat + . for (extraDocFiles pkg_descr) + $ \filename -> + fmap (coerceSymbolicPath . relativeSymbolicPath) + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir filename + , -- Extra files. + fmap concat . for (extraFiles pkg_descr) $ \fpath -> + fmap relativeSymbolicPath + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath + , -- License file(s). + return (map (relativeSymbolicPath . coerceSymbolicPath) $ licenseFiles pkg_descr) + , -- Install-include files, without autogen-include files + fmap concat + . withAllLib + $ \l -> do + let lbi = libBuildInfo l + incls = fmap getSymbolicPath $ filter (`notElem` autogenIncludes lbi) (installIncludes lbi) + relincdirs = fmap getSymbolicPath $ sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs lbi) + traverse (fmap (makeSymbolicPath . snd) . findIncludeFile verbosity cwd relincdirs) incls + , -- Setup script, if it exists. + fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupFile cwd + , -- SetupHooks script, if it exists. + fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupHooksFile cwd + , -- The .cabal file itself. + fmap (\d -> [d]) (coerceSymbolicPath . relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir) + ] + where + cwd = maybe "." getSymbolicPath mbWorkDir + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withAllLib action = traverse action (allLibraries pkg_descr) + withAllFLib action = traverse action (foreignLibs pkg_descr) + withAllExe action = traverse action (executables pkg_descr) + withAllTest action = traverse action (testSuites pkg_descr) + withAllBenchmark action = traverse action (benchmarks pkg_descr) + +-- | Prepare a directory tree of source files. +prepareTree + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do + ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps + installOrdinaryFiles verbosity targetDir (zip (repeat []) $ map i ordinary) + maybeCreateDefaultSetupScript targetDir + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + pkg_descr = filterAutogenModules pkg_descr0 + +-- | Find the setup script file, if it exists. +findSetupFile :: FilePath -> IO (Maybe FilePath) +findSetupFile targetDir = do + hsExists <- doesFileExist (targetDir setupHs) + lhsExists <- doesFileExist (targetDir setupLhs) + if hsExists + then return (Just setupHs) + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "Setup.hs" + setupLhs = "Setup.lhs" + +-- | Find the setup hooks script file, if it exists. +findSetupHooksFile :: FilePath -> IO (Maybe FilePath) +findSetupHooksFile targetDir = do + hsExists <- doesFileExist (targetDir setupHs) + lhsExists <- doesFileExist (targetDir setupLhs) + if hsExists + then return (Just setupHs) + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "SetupHooks.hs" + setupLhs = "SetupHooks.lhs" + +-- | Create a default setup script in the target directory, if it doesn't exist. +maybeCreateDefaultSetupScript :: FilePath -> IO () +maybeCreateDefaultSetupScript targetDir = do + mSetupFile <- findSetupFile targetDir + case mSetupFile of + Just _setupFile -> return () + Nothing -> do + writeUTF8File (targetDir "Setup.hs") $ + unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] + +-- | Find the main executable file. +findMainExeFile + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> BuildInfo + -> [PPSuffixHandler] + -> RelativePath Source File + -- ^ main-is + -> IO (SymbolicPath Pkg File) +findMainExeFile verbosity cwd exeBi pps mainPath = do + ppFile <- + findFileCwdWithExtension + cwd + (ppSuffixes pps) + (hsSourceDirs exeBi) + (dropExtensionsSymbolicPath mainPath) + case ppFile of + Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath + Just pp -> return pp + +-- | Find a module definition file +-- +-- TODO: I don't know if this is right +findModDefFile + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> BuildInfo + -> [PPSuffixHandler] + -> RelativePath Source File + -> IO (SymbolicPath Pkg File) +findModDefFile verbosity cwd flibBi _pps modDefPath = + findFileCwd verbosity cwd (sameDirectory : hsSourceDirs flibBi) modDefPath + +-- | Given a list of include paths, try to find the include file named +-- @f@. Return the name of the file and the full path, or exit with error if +-- there's no such file. +findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) +findIncludeFile verbosity _ [] f = dieWithException verbosity $ NoIncludeFileFound f +findIncludeFile verbosity cwd (d : ds) f = do + let path = d f + b <- doesFileExist (cwd path) + if b then return (f, path) else findIncludeFile verbosity cwd ds f + +-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' +-- and 'other-modules'. +filterAutogenModules :: PackageDescription -> PackageDescription +filterAutogenModules pkg_descr0 = + mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 + where + mapLib f pkg = + pkg + { library = fmap f (library pkg) + , subLibraries = map f (subLibraries pkg) + } + filterAutogenModuleLib lib = + lib + { exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) + } + filterAutogenModuleBI bi = + bi + { otherModules = filter (filterFunction bi) (otherModules bi) + } + pathsModule = autogenPathsModuleName pkg_descr0 + packageInfoModule = autogenPackageInfoModuleName pkg_descr0 + filterFunction bi = \mn -> + mn /= pathsModule + && mn /= packageInfoModule + && not (mn `elem` autogenModules bi) + +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. +prepareSnapshotTree + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () +prepareSnapshotTree verbosity mbWorkDir pkg targetDir pps = do + prepareTree verbosity mbWorkDir pkg targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir + +overwriteSnapshotPackageDesc + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- getSymbolicPath <$> defaultPackageDescCwd verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines + . map (replaceVersion (packageVersion pkg)) + . lines + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line = + "version: " ++ prettyShow version + | otherwise = line + +-- | Modifies a 'PackageDescription' by appending a snapshot number +-- corresponding to the given date. +snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription +snapshotPackage date pkg = + pkg + { package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)} + } + where + pkgid = packageId pkg + +-- | Modifies a 'Version' by appending a snapshot number corresponding +-- to the given date. +snapshotVersion :: UTCTime -> Version -> Version +snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date]) + +-- | Given a date produce a corresponding integer representation. +-- For example given a date @18/03/2008@ produce the number @20080318@. +dateToSnapshotNumber :: UTCTime -> Int +dateToSnapshotNumber date = case toGregorian (utctDay date) of + (year, month, day) -> + fromIntegral year * 10000 + + month * 100 + + day + +-- | Create an archive from a tree of source files, and clean up the tree. +createArchive + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from cabal file + -> FilePath + -- ^ source tree to archive + -> FilePath + -- ^ name of archive to create + -> IO FilePath +createArchive verbosity pkg_descr tmpDir targetPref = do + let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" + (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb + let formatOptSupported = + maybe False (== "YES") $ + Map.lookup + "Supports --format" + (programProperties tarProg) + runProgram verbosity tarProg $ + -- Hmm: I could well be skating on thinner ice here by using the -C option + -- (=> seems to be supported at least by GNU and *BSD tar) [The + -- prev. solution used pipes and sub-command sequences to set up the paths + -- correctly, which is problematic in a Windows setting.] + ["-czf", tarBallFilePath, "-C", tmpDir] + ++ (if formatOptSupported then ["--format", "ustar"] else []) + ++ [tarBallName pkg_descr] + return tarBallFilePath + +-- | Given a buildinfo, return the names of all source files. +allSourcesBuildInfo + :: Verbosity + -> (Verbosity -> CabalException -> IO [SymbolicPath Pkg File]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> BuildInfo + -> [PPSuffixHandler] + -- ^ Extra preprocessors + -> [ModuleName] + -- ^ Exposed modules + -> IO [SymbolicPath Pkg File] +allSourcesBuildInfo verbosity rip mbWorkDir bi pps modules = do + let searchDirs = hsSourceDirs bi + sources <- + fmap concat $ + sequenceA $ + [ let file = moduleNameSymbolicPath module_ + in -- NB: *Not* findFileWithExtension, because the same source + -- file may show up in multiple paths due to a conditional; + -- we need to package all of them. See #367. + findAllFilesCwdWithExtension mbWorkDir suffixes searchDirs file + >>= nonEmpty' (notFound module_) return + | module_ <- modules ++ otherModules bi + ] + bootFiles <- + sequenceA + [ let file = moduleNameSymbolicPath module_ + fileExts = builtinHaskellBootSuffixes + in findFileCwdWithExtension mbWorkDir fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi + ] + + return $ + sources + ++ catMaybes bootFiles + ++ cSources bi + ++ cxxSources bi + ++ cmmSources bi + ++ asmSources bi + ++ jsSources bi + where + nonEmpty' :: b -> ([a] -> b) -> [a] -> b + nonEmpty' x _ [] = x + nonEmpty' _ f xs = f xs + + suffixes = ppSuffixes pps ++ builtinHaskellSuffixes + + notFound :: ModuleName -> IO [SymbolicPath Pkg File] + notFound m = + rip verbosity $ NoModuleFound m suffixes + +-- | Note: must be called with the CWD set to the directory containing +-- the '.cabal' file. +printPackageProblems :: Verbosity -> PackageDescription -> IO () +printPackageProblems verbosity pkg_descr = do + ioChecks <- checkPackageFiles verbosity pkg_descr "." + let pureChecks = checkConfiguredPackage pkg_descr + (errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks) + unless (null errors) $ + notice verbosity $ + "Distribution quality errors:\n" + ++ unlines (map ppPackageCheck errors) + unless (null warnings) $ + notice verbosity $ + "Distribution quality warnings:\n" + ++ unlines (map ppPackageCheck warnings) + unless (null errors) $ + notice + verbosity + "Note: the public hackage server would reject this package." + +------------------------------------------------------------ + +-- | The name of the tarball without extension +tarBallName :: PackageDescription -> String +tarBallName = prettyShow . packageId + +mapAllBuildInfo + :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = + pkg + { library = fmap mapLibBi (library pkg) + , subLibraries = fmap mapLibBi (subLibraries pkg) + , foreignLibs = fmap mapFLibBi (foreignLibs pkg) + , executables = fmap mapExeBi (executables pkg) + , testSuites = fmap mapTestBi (testSuites pkg) + , benchmarks = fmap mapBenchBi (benchmarks pkg) + } + where + mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)} + mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)} + mapExeBi exe = exe{buildInfo = f (buildInfo exe)} + mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)} + mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)} diff --git a/src/Distribution/Simple/Test.hs b/src/Distribution/Simple/Test.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Test.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/setup test@\" action. It runs test suites designated in the package +-- description and reports on the results. +module Distribution.Simple.Test + ( test + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build (addInternalBuildTools) +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Setup.Test +import qualified Distribution.Simple.Test.ExeV10 as ExeV10 +import qualified Distribution.Simple.Test.LibV09 as LibV09 +import Distribution.Simple.Test.Log +import Distribution.Simple.UserHooks +import Distribution.Simple.Utils +import Distribution.TestSuite +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Types.UnqualComponentName +import Distribution.Utils.Path + +import Distribution.Simple.Configure (getInstalledPackagesById) +import Distribution.Simple.Errors +import Distribution.Simple.Register (internalPackageDBPath) +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.Types.ExposedModule +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) +import System.Directory + ( createDirectoryIfMissing + , doesFileExist + , getDirectoryContents + , removeFile + ) + +-- | Perform the \"@.\/setup test@\" action. +test + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> TestFlags + -- ^ flags sent to test + -> IO () +test args pkg_descr lbi0 flags = do + curDir <- LBI.absoluteWorkingDirLBI lbi0 + let common = testCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref = fromFlag $ setupDistPref common + i = LBI.interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + machineTemplate = fromFlag $ testMachineLog flags + testLogDir = distPref makeRelativePathEx "test" + testNames = args + pkgTests = PD.testSuites pkg_descr + enabledTests = LBI.enabledTestLBIs pkg_descr lbi + -- We must add the internalPkgDB to the package database stack to lookup + -- the path to HPC dirs of libraries local to this package + internalPkgDb = internalPackageDBPath lbi0 distPref + lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDb]} + + doTest + :: HPCMarkupInfo + -> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo) + , Maybe TestSuiteLog + ) + -> IO TestSuiteLog + doTest hpcMarkupInfo ((suite, clbi), _) = do + let lbiForTest = + lbi + { withPrograms = + -- Include any build-tool-depends on build tools internal to the current package. + addInternalBuildTools + curDir + pkg_descr + lbi + (PD.testBuildInfo suite) + (withPrograms lbi) + } + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> + ExeV10.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + PD.TestSuiteLibV09 _ _ -> + LibV09.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + _ -> + return + TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = + TestLog + { testName = unUnqualComponentName $ PD.testName suite + , testOptionsReturned = [] + , testResult = + Error $ + "No support for running test suite type: " + ++ show (pretty $ PD.testType suite) + } + , logFile = "" + } + + unless (PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + dieWithException verbosity NoTestSuitesEnabled + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> for names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map (PD.testName . fst) enabledTests + allNames = map PD.testName pkgTests + tCompName = mkUnqualComponentName tName + in case lookup tCompName testMap of + Just t -> return (t, Nothing) + _ + | tCompName `elem` allNames -> + dieWithException verbosity $ TestNameDisabled tName + | otherwise -> dieWithException verbosity $ NoSuchTest tName + + createDirectoryIfMissing True $ i testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents (i testLogDir) + >>= filterM doesFileExist . map (i testLogDir ) + >>= traverse_ removeFile + + -- We configured the unit-ids of libraries we should cover in our coverage + -- report at configure time into the local build info. At build time, we built + -- the hpc artifacts into the extraCompilationArtifacts directory, which, at + -- install time, is copied into the ghc-pkg database files. + -- Now, we get the path to the HPC artifacts and exposed modules of each + -- library by querying the package database keyed by unit-id: + let coverageFor = + nub $ + fromFlagOrDefault [] (configCoverageFor (configFlags lbi)) + <> extraCoverageFor lbi + ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor + let ( concat -> pathsToLibsArtifacts + , concat -> libsModulesToInclude + ) = + unzip $ + map + ( \ip -> + ( map (( coerceSymbolicPath extraCompilationArtifacts) . makeSymbolicPath) $ libraryDirs ip + , map exposedName $ exposedModules ip + ) + ) + ipkginfos + hpcMarkupInfo = HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- traverse (doTest hpcMarkupInfo) testsToRun + let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites} + packageLogFile = + i testLogDir + packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + + when (LBI.testCoverage lbi) $ + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $ + map (fst . fst) testsToRun + + unless allOk exitFailure + +packageLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) diff --git a/src/Distribution/Simple/Test/ExeV10.hs b/src/Distribution/Simple/Test/ExeV10.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Test/ExeV10.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.Test.ExeV10 + ( runTest + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.Hpc +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( ComponentLocalBuildInfo (..) + , buildDir + , depLibraryPaths + ) +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Test +import Distribution.Simple.Test.Log +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import qualified Distribution.Types.LocalBuildInfo as LBI + ( LocalBuildInfo (..) + , localUnitId + , testCoverage + ) +import Distribution.Types.UnqualComponentName +import Distribution.Verbosity + +import Distribution.Utils.Path + +import qualified Data.ByteString.Lazy as LBS +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + ) +import System.IO (stderr, stdout) +import System.Process (createPipe) + +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> HPCMarkupInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + tixDir_ = i $ tixDir distPref way + + let cmd = + i (LBI.buildDir lbi) + testName' + testName' <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + Couldn'tFindTestProgram cmd + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tixDir_ + when exists' $ removeDirectoryRecursive tixDir_ + + -- Create directory for HPC files. + createDirectoryIfMissing True tixDir_ + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ testName' + + -- Run the test executable (with the appropriate environment set) + let progDb = LBI.withPrograms lbi + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar + let opts = + map + (testOption pkg_descr lbi suite) + (testOptions flags) + tixFile = packageRoot (testCommonFlags flags) getSymbolicPath (tixFilePath distPref way (testName')) + + shellEnv <- + getFullEnvironment + ( [("PATH", Just newPath)] + ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled] + ++ envOverrides + ) + + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv + + -- Output logger + (wOut, wErr, getLogText) <- case details of + Direct -> return (stdout, stderr, return LBS.empty) + _ -> do + (rOut, wOut) <- createPipe + + return $ (,,) wOut wOut $ do + -- Read test executables' output + logText <- LBS.hGetContents rOut + + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ LBS.putStr logText + + -- drain the output. + evaluate (force logText) + + let mbWorkDir = + interpretSymbolicPathCWD + <$> flagToMaybe (setupWorkingDir (testCommonFlags flags)) + + (exit, logText) <- case testWrapper flags of + Flag path -> + rawSystemIOWithEnvAndAction + verbosity + path + (cmd : opts) + mbWorkDir + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) + NoFlag -> + rawSystemIOWithEnvAndAction + verbosity + cmd + opts + mbWorkDir + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log. + let suiteLog = buildLog exit + + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + + -- Append contents of temporary log file to the final human- + -- readable log file + LBS.appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let whenPrinting = + when $ + ( details == Always + || details == Failures && not (suitePassed $ testLogs suiteLog) + ) + -- verbosity overrides show-details + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ do + -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per + -- library and there being at least one library in the package with the + -- testsuite. When it is fixed, we can remove this predicate and allow a + -- testsuite without a library to cover libraries in other packages of the + -- same project + when (null $ PD.allLibraries pkg_descr) $ + dieWithException verbosity TestCoverageSupport + + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] + + return suiteLog + where + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + commonFlags = testCommonFlags flags + + testName' = unUnqualComponentName $ PD.testName suite + + distPref = fromFlag $ setupDistPref commonFlags + verbosity = fromFlag $ setupVerbosity commonFlags + details = fromFlag $ testShowDetails flags + testLogDir = distPref makeRelativePathEx "test" + + buildLog exit = + let r = case exit of + ExitSuccess -> Pass + ExitFailure c -> Fail $ "exit code: " ++ show c + -- n = unUnqualComponentName $ PD.testName suite + l = + TestLog + { testName = testName' + , testOptionsReturned = [] + , testResult = r + } + in TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = l + , logFile = + i testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + testName' + l + } + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] diff --git a/src/Distribution/Simple/Test/LibV09.hs b/src/Distribution/Simple/Test/LibV09.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Test/LibV09.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.Test.LibV09 + ( runTest + -- Test stub + , simpleTestStub + , stubFilePath + , stubMain + , stubName + , stubWriteLog + , writeSimpleTestStub + ) where + +import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName +import Prelude () + +import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Process (proc) +import Distribution.ModuleName +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Hpc +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Test +import Distribution.Simple.Test.Log +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Utils.Path +import Distribution.Verbosity + +import qualified Control.Exception as CE +import qualified Data.ByteString.Lazy as LBS +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + , removeFile + , setCurrentDirectory + ) +import System.IO (hClose, hPutStr) +import qualified System.Process as Process + +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> HPCMarkupInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + + let mbWorkDir = LBI.mbWorkDirLBI lbi + + let cmd = + interpretSymbolicPath mbWorkDir (LBI.buildDir lbi) + stubName suite + stubName suite <.> exeExtension (LBI.hostPlatform lbi) + tDir = i $ tixDir distPref way + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + Couldn'tFindTestProgLibV09 cmd + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tDir + when exists' $ removeDirectoryRecursive tDir + + -- Create directory for HPC files. + createDirectoryIfMissing True tDir + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart testName' + + suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + -- Compute the appropriate environment for running the test suite + let progDb = LBI.withPrograms lbi + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar + + -- Run test executable + let opts = map (testOption pkg_descr lbi suite) $ testOptions flags + tixFile = i $ tixFilePath distPref way testName' + + shellEnv <- + getFullEnvironment + ( [("PATH", Just newPath)] + ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled] + ++ envOverrides + ) + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + cpath <- canonicalizePath $ i $ LBI.componentBuildDir lbi clbi + return (addLibraryPath os (cpath : paths) shellEnv) + else return shellEnv + let (cmd', opts') = case testWrapper flags of + Flag path -> (path, cmd : opts) + NoFlag -> (cmd, opts) + + -- TODO: this setup is broken, + -- if the test output is too big, we will deadlock. + (rOut, wOut) <- Process.createPipe + (exitcode, logText) <- rawSystemProcAction + verbosity + (proc cmd' opts') + { Process.env = Just shellEnv' + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.UseHandle wOut + , Process.std_err = Process.UseHandle wOut + } + $ \mIn _ _ -> do + let wIn = fromCreatePipe mIn + hPutStr wIn $ show (tempLog, PD.testName suite) + hClose wIn + + -- Append contents of temporary log file to the final human- + -- readable log file + logText <- LBS.hGetContents rOut + -- Force the IO manager to drain the test output pipe + _ <- evaluate (force logText) + return logText + unless (exitcode == ExitSuccess) $ + debug verbosity $ + cmd ++ " returned " ++ show exitcode + + -- Generate final log file name + let finalLogName l = + interpretSymbolicPath mbWorkDir testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + (unUnqualComponentName $ testSuiteName l) + (testLogs l) + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- + fmap + ( \s -> + (\l -> l{logFile = finalLogName l}) + . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) + $ readMaybe s -- TODO: eradicateNoParse + ) + $ readFile tempLog + + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + + LBS.appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = + when $ + (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' + + return suiteLog + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ do + -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per + -- library and there being at least one library in the package with the + -- testsuite. When it is fixed, we can remove this predicate and allow a + -- testsuite without a library to cover libraries in other packages of the + -- same project + when (null $ PD.allLibraries pkg_descr) $ + dieWithException verbosity TestCoverageSupport + + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] + + return suiteLog + where + i = LBI.interpretSymbolicPathLBI lbi + common = testCommonFlags flags + testName' = unUnqualComponentName $ PD.testName suite + + deleteIfExists file = do + exists <- doesFileExist file + when exists $ removeFile file + + testLogDir = distPref makeRelativePathEx "test" + openCabalTemp = do + (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log" + hClose h >> return f + + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + +-- Test stub ---------- + +-- | The filename of the source file for the stub executable associated with a +-- library 'TestSuite'. +stubFilePath :: PD.TestSuite -> FilePath +stubFilePath t = stubName t <.> "hs" + +-- | Write the source file for a library 'TestSuite' stub executable. +writeSimpleTestStub + :: PD.TestSuite + -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath + -- ^ path to directory where stub source + -- should be located + -> IO () +writeSimpleTestStub t dir = do + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + m = case PD.testInterface t of + PD.TestSuiteLibV09 _ m' -> m' + _ -> error "writeSimpleTestStub: invalid TestSuite passed" + writeFile filename $ simpleTestStub m + +-- | Source code for library test suite stub executable +simpleTestStub :: ModuleName -> String +simpleTestStub m = + unlines + [ "module Main ( main ) where" + , "import Distribution.Simple.Test.LibV09 ( stubMain )" + , "import " ++ show (pretty m) ++ " ( tests )" + , "main :: IO ()" + , "main = stubMain tests" + ] + +-- | Main function for test stubs. Once, it was written directly into the stub, +-- but minimizing the amount of code actually in the stub maximizes the number +-- of detectable errors when Cabal is compiled. +stubMain :: IO [Test] -> IO () +stubMain tests = do + (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse + dir <- getCurrentDirectory + results <- (tests >>= stubRunTests) `CE.catch` errHandler + setCurrentDirectory dir + stubWriteLog f n results + where + errHandler :: CE.SomeException -> IO TestLogs + errHandler e = case CE.fromException e of + Just CE.UserInterrupt -> CE.throwIO e + _ -> + return $ + TestLog + { testName = "Cabal test suite exception" + , testOptionsReturned = [] + , testResult = Error $ show e + } + +-- | The test runner used in library "TestSuite" stub executables. Runs a list +-- of 'Test's. An executable calling this function is meant to be invoked as +-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', +-- provided by Cabal, is read from the standard input; it supplies the name of +-- the test suite and the location of the machine-readable test suite log file. +-- Human-readable log information is written to the standard output for capture +-- by the calling Cabal process. +stubRunTests :: [Test] -> IO TestLogs +stubRunTests tests = do + logs <- traverse stubRunTests' tests + return $ GroupLogs "Default" logs + where + stubRunTests' (Test t) = do + l <- run t >>= finish + summarizeTest normal Always l + return l + where + finish (Finished result) = + return + TestLog + { testName = name t + , testOptionsReturned = defaultOptions t + , testResult = result + } + finish (Progress _ next) = next >>= finish + stubRunTests' g@(Group{}) = do + logs <- traverse stubRunTests' $ groupTests g + return $ GroupLogs (groupName g) logs + stubRunTests' (ExtraOptions _ t) = stubRunTests' t + maybeDefaultOption opt = + maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst + +-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling +-- Cabal process to read. +stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () +stubWriteLog f n logs = do + let testLog = TestSuiteLog{testSuiteName = n, testLogs = logs, logFile = f} + writeFile (logFile testLog) $ show testLog + when (suiteError logs) $ exitWith $ ExitFailure 2 + when (suiteFailed logs) $ exitWith $ ExitFailure 1 + exitSuccess diff --git a/src/Distribution/Simple/Test/Log.hs b/src/Distribution/Simple/Test/Log.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Test/Log.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.Test.Log + ( PackageLog (..) + , TestLogs (..) + , TestSuiteLog (..) + , countTestResults + , localPackageLog + , summarizePackage + , summarizeSuiteFinish + , summarizeSuiteStart + , summarizeTest + , suiteError + , suiteFailed + , suitePassed + , testSuiteLogPath + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Package +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never)) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import Distribution.Types.UnqualComponentName +import Distribution.Verbosity + +import qualified Prelude (foldl1) + +-- | Logs all test results for a package, broken down first by test suite and +-- then by test case. +data PackageLog = PackageLog + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) + +-- | A 'PackageLog' with package and platform information specified. +localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog +localPackageLog pkg_descr lbi = + PackageLog + { package = PD.package pkg_descr + , compiler = compilerId $ LBI.compiler lbi + , platform = LBI.hostPlatform lbi + , testSuites = [] + } + +-- | Logs test suite results, itemized by test case. +data TestSuiteLog = TestSuiteLog + { testSuiteName :: UnqualComponentName + , testLogs :: TestLogs + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) + +data TestLogs + = TestLog + { testName :: String + , testOptionsReturned :: Options + , testResult :: Result + } + | GroupLogs String [TestLogs] + deriving (Read, Show, Eq) + +-- | Count the number of pass, fail, and error test results in a 'TestLogs' +-- tree. +countTestResults + :: TestLogs + -> (Int, Int, Int) + -- ^ Passes, fails, and errors, + -- respectively. +countTestResults = go (0, 0, 0) + where + go (p, f, e) (TestLog{testResult = r}) = + case r of + Pass -> (p + 1, f, e) + Fail _ -> (p, f + 1, e) + Error _ -> (p, f, e + 1) + go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts + +-- | From a 'TestSuiteLog', determine if the test suite passed. +suitePassed :: TestLogs -> Bool +suitePassed l = + case countTestResults l of + (_, 0, 0) -> True + _ -> False + +-- | From a 'TestSuiteLog', determine if the test suite failed. +suiteFailed :: TestLogs -> Bool +suiteFailed l = + case countTestResults l of + (_, 0, _) -> False + _ -> True + +-- | From a 'TestSuiteLog', determine if the test suite encountered errors. +suiteError :: TestLogs -> Bool +suiteError l = + case countTestResults l of + (_, _, 0) -> False + _ -> True + +resultString :: TestLogs -> String +resultString l + | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> String + -- ^ test suite name + -> TestLogs + -- ^ test suite results + -> FilePath +testSuiteLogPath template pkg_descr lbi test_name result = + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [ (TestSuiteNameVar, toPathTemplate test_name) + , (TestSuiteResultVar, toPathTemplate $ resultString result) + ] + +-- | Print a summary to the console after all test suites have been run +-- indicating the number of successful test suites and cases. Returns 'True' if +-- all test suites passed and 'False' otherwise. +summarizePackage :: Verbosity -> PackageLog -> IO Bool +summarizePackage verbosity packageLog = do + let counts = map (countTestResults . testLogs) $ testSuites packageLog + (passed, failed, errors) = Prelude.foldl1 addTriple counts + totalCases = passed + failed + errors + passedSuites = + length $ + filter (suitePassed . testLogs) $ + testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ + show passedSuites + ++ " of " + ++ show totalSuites + ++ " test suites (" + ++ show passed + ++ " of " + ++ show totalCases + ++ " test cases) passed." + return $! passedSuites == totalSuites + where + addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) + +-- | Print a summary of a single test case's result to the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () +summarizeTest _ _ (GroupLogs{}) = return () +summarizeTest verbosity details t = + when shouldPrint $ + notice verbosity $ + "Test case " + ++ testName t + ++ ": " + ++ show (testResult t) + where + shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = testResult t /= Pass + +-- | Print a summary of the test suite's results on the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeSuiteFinish :: TestSuiteLog -> String +summarizeSuiteFinish testLog = + unlines + [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr + , "Test suite logged to: " ++ logFile testLog + ] + where + resStr = map toUpper (resultString $ testLogs testLog) + +summarizeSuiteStart :: String -> String +summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" diff --git a/src/Distribution/Simple/UHC.hs b/src/Distribution/Simple/UHC.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/UHC.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for +-- inspiration on how to design this module. +module Distribution.Simple.UHC + ( configure + , getInstalledPackages + , buildLib + , buildExe + , installLib + , registerPackage + , inplacePackageDbPath + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.InstalledPackageInfo +import Distribution.Package hiding (installedUnitId) +import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.MungedPackageId +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension + +import qualified Data.Map as Map (empty) +import System.Directory +import System.FilePath (pathSeparator) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure + :: Verbosity + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath progdb = do + (_uhcProg, uhcVersion, progdb') <- + requireProgramVersion + verbosity + uhcProgram + (orLaterVersion (mkVersion [1, 0, 2])) + (userMaybeSpecifyPath "uhc" hcPath progdb) + + let comp = + Compiler + { compilerId = CompilerId UHC uhcVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = uhcLanguages + , compilerExtensions = uhcLanguageExtensions + , compilerProperties = Map.empty + } + compPlatform = Nothing + return (comp, compPlatform, progdb') + +uhcLanguages :: [(Language, CompilerFlag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] +uhcLanguageExtensions = + let doFlag (f, (enable, disable)) = + [ (EnableExtension f, enable) + , (DisableExtension f, disable) + ] + alwaysOn = (Nothing, Nothing {- wrong -}) + in concatMap + doFlag + [ (CPP, (Just "--cpp", Nothing {- wrong -})) + , (PolymorphicComponents, alwaysOn) + , (ExistentialQuantification, alwaysOn) + , (ForeignFunctionInterface, alwaysOn) + , (UndecidableInstances, alwaysOn) + , (MultiParamTypeClasses, alwaysOn) + , (Rank2Types, alwaysOn) + , (PatternSignatures, alwaysOn) + , (EmptyDataDecls, alwaysOn) + , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -})) + , (TypeOperators, alwaysOn) + , (OverlappingInstances, alwaysOn) + , (FlexibleInstances, alwaysOn) + ] + +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do + let compilerid = compilerId comp + systemPkgDir <- getGlobalPackageDir verbosity progdb + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + pkgs <- + liftM (map addBuiltinVersions . concat) $ + traverse + (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) + pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath +getGlobalPackageDir verbosity progdb = do + output <- + getDbProgramOutput + verbosity + uhcProgram + progdb + ["--meta-pkgdir-system"] + -- we need to trim because pkgdir contains an extra newline at the end + let pkgdir = trimEnd output + return pkgdir + where + trimEnd = dropWhileEnd isSpace + +getUserPackageDir :: IO FilePath +getUserPackageDir = do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths + :: FilePath + -> FilePath + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> [FilePath] +packageDbPaths user system mbWorkDir db = + case db of + GlobalPackageDB -> [system] + UserPackageDB -> [user] + SpecificPackageDB path -> [interpretSymbolicPath mbWorkDir path] + +-- | Hack to add version numbers to UHC-built-in packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage = toList . simpleParsec + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = + emptyInstalledPackageInfo + { installedUnitId = mkLegacyUnitId p + , sourcePackageId = p + } + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) + userPkgDir <- getUserPackageDir + let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) + let uhcArgs = + -- set package name + ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (libBuildInfo lib) + clbi + (buildDir lbi) + verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map + (map (\c -> if c == '.' then pathSeparator else c)) + (map prettyShow (allLibModules lib clbi)) + + runUhcProg uhcArgs + + return () + +buildExe + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) + userPkgDir <- getUserPackageDir + let mbWorkDir = mbWorkDirLBI lbi + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs $ buildInfo exe) (modulePath exe) + let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) + u = interpretSymbolicPathCWD + uhcArgs = + -- common flags lib/exe + constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (buildInfo exe) + clbi + (buildDir lbi) + verbosity + -- output file + ++ ["--output", u $ buildDir lbi makeRelativePathEx (prettyShow (exeName exe))] + -- main source module + ++ [u $ srcMainPath] + runUhcProg uhcArgs + +constructUHCCmdLine + :: FilePath + -> FilePath + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Build) + -> Verbosity + -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + ( if verbosity >= deafening + then ["-v4"] + else + if verbosity >= normal + then [] + else ["-v0"] + ) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] + -- search paths + ++ ["-i" ++ u odir] + ++ ["-i" ++ u l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)] + ++ ["-i" ++ u (autogenPackageModulesDir lbi)] + -- cpp options + ++ ["--optP=" ++ opt | opt <- cppOptions bi] + -- output path + ++ ["--odir=" ++ u odir] + -- optimization + ++ ( case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"] + ) + where + u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = + map + (\x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system Nothing) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> FilePath + -> FilePath + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir + +-- currently hard-coded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> Compiler + -> ProgramDb + -> PackageDBStackS from + -> InstalledPackageInfo + -> IO () +registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo = do + dbdir <- case registrationPackageDB packageDbs of + GlobalPackageDB -> getGlobalPackageDir verbosity progdb + UserPackageDB -> getUserPackageDir + SpecificPackageDB dir -> return (interpretSymbolicPath mbWorkDir dir) + let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File + (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = sourcePackageId installedPkgInfo + compilerid = compilerId comp + +inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB) +inplacePackageDbPath lbi = coerceSymbolicPath $ buildDir lbi diff --git a/src/Distribution/Simple/UserHooks.hs b/src/Distribution/Simple/UserHooks.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/UserHooks.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. +-- +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- various phases because it would involve changing the types of the +-- corresponding hook. At some point it will have to be replaced. +module Distribution.Simple.UserHooks + ( UserHooks (..) + , Args + , emptyUserHooks + ) where + +import Distribution.Compat.Prelude hiding (getContents, putStr) +import Prelude () + +import Distribution.PackageDescription +import Distribution.Simple.Command +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Setup + +type Args = [String] + +-- | Hooks allow authors to add specific functionality before and after a +-- command is run, and also to specify additional preprocessors. +-- +-- * WARNING: The hooks interface is under rather constant flux as we try to +-- understand users needs. Setup files that depend on this interface may +-- break in future releases. +data UserHooks = UserHooks + { readDesc :: IO (Maybe GenericPackageDescription) + -- ^ Read the description file + , hookedPreProcessors :: [PPSuffixHandler] + -- ^ Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + , hookedPrograms :: [Program] + -- ^ These programs are detected at configure time. Arguments for them are + -- added to the configure command. + , preConf :: Args -> ConfigFlags -> IO HookedBuildInfo + -- ^ Hook to run before configure command + , confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + -- ^ Over-ride this hook to get different behavior during configure. + , postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after configure command + , preBuild :: Args -> BuildFlags -> IO HookedBuildInfo + -- ^ Hook to run before build command. Second arg indicates verbosity level. + , buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () + -- ^ Over-ride this hook to get different behavior during build. + , postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after build command. Second arg indicates verbosity level. + , preRepl :: Args -> ReplFlags -> IO HookedBuildInfo + -- ^ Hook to run before repl command. Second arg indicates verbosity level. + , replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () + -- ^ Over-ride this hook to get different behavior during interpretation. + , postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after repl command. Second arg indicates verbosity level. + , preClean :: Args -> CleanFlags -> IO HookedBuildInfo + -- ^ Hook to run before clean command. Second arg indicates verbosity level. + , cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO () + -- ^ Over-ride this hook to get different behavior during clean. + , postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO () + -- ^ Hook to run after clean command. Second arg indicates verbosity level. + , preCopy :: Args -> CopyFlags -> IO HookedBuildInfo + -- ^ Hook to run before copy command + , copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () + -- ^ Over-ride this hook to get different behavior during copy. + , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after copy command + , preInst :: Args -> InstallFlags -> IO HookedBuildInfo + -- ^ Hook to run before install command + , instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () + -- ^ Over-ride this hook to get different behavior during install. + , postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + , preReg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before register command + , regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during registration. + , postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after register command + , preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before unregister command + , unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during unregistration. + , postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after unregister command + , preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo + -- ^ Hook to run before hscolour command. Second arg indicates verbosity level. + , hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO () + -- ^ Over-ride this hook to get different behavior during hscolour. + , postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after hscolour command. Second arg indicates verbosity level. + , preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo + -- ^ Hook to run before haddock command. Second arg indicates verbosity level. + , haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () + -- ^ Over-ride this hook to get different behavior during haddock. + , postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after haddock command. Second arg indicates verbosity level. + , preTest :: Args -> TestFlags -> IO HookedBuildInfo + -- ^ Hook to run before test command. + , testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () + -- ^ Over-ride this hook to get different behavior during test. + , postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after test command. + , preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo + -- ^ Hook to run before bench command. + , benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () + -- ^ Over-ride this hook to get different behavior during bench. + , postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after bench command. + } + +-- | Empty 'UserHooks' which do nothing. +emptyUserHooks :: UserHooks +emptyUserHooks = + UserHooks + { readDesc = return Nothing + , hookedPreProcessors = [] + , hookedPrograms = [] + , preConf = rn' + , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")) + , postConf = ru + , preBuild = rn' + , buildHook = ru + , postBuild = ru + , preRepl = \_ _ -> return emptyHookedBuildInfo + , replHook = \_ _ _ _ _ -> return () + , postRepl = ru + , preClean = rn + , cleanHook = ru + , postClean = ru + , preCopy = rn' + , copyHook = ru + , postCopy = ru + , preInst = rn + , instHook = ru + , postInst = ru + , preReg = rn' + , regHook = ru + , postReg = ru + , preUnreg = rn + , unregHook = ru + , postUnreg = ru + , preHscolour = rn + , hscolourHook = ru + , postHscolour = ru + , preHaddock = rn' + , haddockHook = ru + , postHaddock = ru + , preTest = rn' + , testHook = \_ -> ru + , postTest = ru + , preBench = rn' + , benchHook = \_ -> ru + , postBench = ru + } + where + rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + rn' _ _ = return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/src/Distribution/Simple/Utils.hs b/src/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Utils.hs @@ -0,0 +1,2072 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +#ifdef GIT_REV +{-# LANGUAGE TemplateHaskell #-} +#endif + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. +module Distribution.Simple.Utils + ( cabalVersion + , cabalGitInfo + + -- * logging and errors + , dieNoVerbosity + , die' + , dieWithException + , dieWithLocation' + , dieNoWrap + , topHandler + , topHandlerWith + , warn + , warnError + , notice + , noticeNoWrap + , noticeDoc + , setupMessage + , info + , infoNoWrap + , debug + , debugNoWrap + , chattyTry + , annotateIO + , exceptionWithMetadata + , withOutputMarker + + -- * exceptions + , handleDoesNotExist + , ignoreSigPipe + + -- * running programs + , rawSystemExit + , rawSystemExitCode + , rawSystemProc + , rawSystemProcAction + , rawSystemExitWithEnv + , rawSystemExitWithEnvCwd + , rawSystemStdout + , rawSystemStdInOut + , rawSystemIOWithEnv + , rawSystemIOWithEnvAndAction + , fromCreatePipe + , maybeExit + , xargs + , findProgramVersion + + -- ** 'IOData' re-export + + -- + -- These types are re-exported from + -- "Distribution.Utils.IOData" for convenience as they're + -- exposed in the API of 'rawSystemStdInOut' + , IOData (..) + , KnownIODataMode (..) + , IODataMode (..) + , VerboseException (..) + + -- * copying files + , createDirectoryIfMissingVerbose + , copyFileVerbose + , copyFiles + , copyFileTo + , copyFileToCwd + + -- * installing files + , installOrdinaryFile + , installExecutableFile + , installMaybeExecutableFile + , installOrdinaryFiles + , installExecutableFiles + , installMaybeExecutableFiles + , installDirectoryContents + , copyDirectoryRecursive + + -- * File permissions + , doesExecutableExist + , setFileOrdinary + , setFileExecutable + + -- * file names + , shortRelativePath + , dropExeExtension + , exeExtensions + + -- * finding files + , findFileEx + , findFileCwd + , findFirstFile + , Suffix (..) + , findFileWithExtension + , findFileCwdWithExtension + , findFileWithExtension' + , findFileCwdWithExtension' + , findAllFilesWithExtension + , findAllFilesCwdWithExtension + , findModuleFileEx + , findModuleFileCwd + , findModuleFilesEx + , findModuleFilesCwd + , getDirectoryContentsRecursive + + -- * environment variables + , isInSearchPath + , addLibraryPath + + -- * modification time + , moreRecentFile + , existsAndIsMoreRecentThan + + -- * temp files and dirs + , TempFileOptions (..) + , defaultTempFileOptions + , withTempFile + , withTempFileCwd + , withTempFileEx + , withTempDirectory + , withTempDirectoryCwd + , withTempDirectoryEx + , withTempDirectoryCwdEx + , createTempDirectory + + -- * .cabal and .buildinfo files + , defaultPackageDescCwd + , findPackageDesc + , tryFindPackageDesc + , findHookedPackageDesc + + -- * reading and writing files safely + , withFileContents + , writeFileAtomic + , rewriteFileEx + , rewriteFileLBS + + -- * Unicode + , fromUTF8BS + , fromUTF8LBS + , toUTF8BS + , toUTF8LBS + , readUTF8File + , withUTF8FileContents + , writeUTF8File + , normaliseLineEndings + + -- * BOM + , ignoreBOM + + -- * generic utils + , dropWhileEndLE + , takeWhileEndLE + , equating + , comparing + , isInfixOf + , intercalate + , lowercase + , listUnion + , listUnionRight + , ordNub + , sortNub + , ordNubBy + , ordNubRight + , safeHead + , safeTail + , safeLast + , safeInit + , unintersperse + , wrapText + , wrapLine + , stripCommonPrefix + + -- * FilePath stuff + , isAbsoluteOnAnyPlatform + , isRelativeOnAnyPlatform + , exceptionWithCallStackPrefix + ) where + +import Distribution.Compat.Async (waitCatch, withAsyncNF) +import Distribution.Compat.CopyFile +import Distribution.Compat.FilePath as FilePath +import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Lens (Lens', over) +import Distribution.Compat.Prelude +import Distribution.Compat.Stack +import Distribution.ModuleName as ModuleName +import Distribution.Simple.Errors +import Distribution.Simple.PreProcess.Types +import Distribution.System +import Distribution.Types.PackageId +import Distribution.Utils.Generic +import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..)) +import qualified Distribution.Utils.IOData as IOData +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Prelude () + +#ifdef CURRENT_PACKAGE_KEY +#define BOOTSTRAPPED_CABAL 1 +#endif + +#ifdef BOOTSTRAPPED_CABAL +import qualified Paths_Cabal (version) +#endif + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.ByteString.Lazy as BS +import Data.Typeable + ( cast + ) + +import qualified Control.Exception as Exception +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Distribution.Compat.Process (proc) +import Foreign.C.Error (Errno (..), ePIPE) +import qualified GHC.IO.Exception as GHC +import GHC.Stack (HasCallStack) +import Numeric (showFFloat) +import System.Directory + ( Permissions (executable) + , createDirectory + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , getModificationTime + , getPermissions + , getTemporaryDirectory + , removeDirectoryRecursive + , removeFile + ) +import System.Environment + ( getProgName + ) +import System.FilePath (takeFileName) +import System.FilePath as FilePath + ( getSearchPath + , joinPath + , normalise + , searchPathSeparator + , splitDirectories + , splitExtension + , takeDirectory + ) +import System.IO + ( BufferMode (..) + , Handle + , hClose + , hFlush + , hGetContents + , hPutStr + , hPutStrLn + , hSetBinaryMode + , hSetBuffering + , stderr + , stdout + ) +import System.IO.Error +import System.IO.Unsafe + ( unsafeInterleaveIO + ) +import qualified System.Process as Process +import qualified Text.PrettyPrint as Disp + +#ifdef GIT_REV +import Data.Either (isLeft) +import GitHash + ( giHash + , giBranch + , giCommitDate + , tGitInfoCwdTry + ) +#endif + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(BOOTSTRAPPED_CABAL) +cabalVersion = mkVersion' Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = mkVersion [CABAL_VERSION] +#else +cabalVersion = mkVersion [3,0] --used when bootstrapping +#endif + +-- | +-- `Cabal` Git information. Only filled in if built in a Git tree in +-- development mode and Template Haskell is available. +cabalGitInfo :: String +#ifdef GIT_REV +cabalGitInfo = if giHash' == "" + then "" + else concat [ "(commit " + , giHash' + , branchInfo + , ", " + , either (const "") giCommitDate gi' + , ")" + ] + where + gi' = $$tGitInfoCwdTry + giHash' = take 7 . either (const "") giHash $ gi' + branchInfo | isLeft gi' = "" + | either id giBranch gi' == "master" = "" + | otherwise = " on " <> either id giBranch gi' +#else +cabalGitInfo = "" +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +-- Cabal's logging infrastructure has a few constraints: +-- +-- * We must make all logging formatting and emissions decisions based +-- on the 'Verbosity' parameter, which is the only parameter that is +-- plumbed to enough call-sites to actually be used for this matter. +-- (One of Cabal's "big mistakes" is to have never have defined a +-- monad of its own.) +-- +-- * When we 'die', we must raise an IOError. This a backwards +-- compatibility consideration, because that's what we've raised +-- previously, and if we change to any other exception type, +-- exception handlers which match on IOError will no longer work. +-- One case where it is known we rely on IOError being catchable +-- is 'readPkgConfigDb' in cabal-install; there may be other +-- user code that also assumes this. +-- +-- * The 'topHandler' does not know what 'Verbosity' is, because +-- it gets called before we've done command line parsing (where +-- the 'Verbosity' parameter would come from). +-- +-- This leads to two big architectural choices: +-- +-- * Although naively we might imagine 'Verbosity' to be a simple +-- enumeration type, actually it is a full-on abstract data type +-- that may contain arbitrarily complex information. At the +-- moment, it is fully representable as a string, but we might +-- eventually also use verbosity to let users register their +-- own logging handler. +-- +-- * When we call 'die', we perform all the formatting and addition +-- of extra information we need, and then ship this in the IOError +-- to the top-level handler. Here are alternate designs that +-- don't work: +-- +-- a) Ship the unformatted info to the handler. This doesn't +-- work because at the point the handler gets the message, +-- we've lost call stacks, and even if we did, we don't have access +-- to 'Verbosity' to decide whether or not to render it. +-- +-- b) Print the information at the 'die' site, then raise an +-- error. This means that if the exception is subsequently +-- caught by a handler, we will still have emitted the output, +-- which is not the correct behavior. +-- +-- For the top-level handler to "know" that an error message +-- contains one of these fully formatted packets, we set a sentinel +-- in one of IOError's extra fields. This is handled by +-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. +-- + +dieNoVerbosity :: String -> IO a +dieNoVerbosity msg = + ioError (userError msg) + where + _ = callStack -- TODO: Attach CallStack to exception + +-- | Tag an 'IOError' whose error string should be output to the screen +-- verbatim. +ioeSetVerbatim :: IOError -> IOError +ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" + +-- | Check if an 'IOError' should be output verbatim to screen. +ioeGetVerbatim :: IOError -> Bool +ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" + +-- | Create a 'userError' whose error text will be output verbatim +verbatimUserError :: String -> IOError +verbatimUserError = ioeSetVerbatim . userError + +dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a +dieWithLocation' verbosity filename mb_lineno msg = + die' verbosity $ + filename + ++ ( case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "" + ) + ++ ": " + ++ msg + +die' :: Verbosity -> String -> IO a +die' verbosity msg = withFrozenCallStack $ do + ioError . verbatimUserError + =<< annotateErrorString verbosity + =<< pure . wrapTextVerbosity verbosity + =<< pure . addErrorPrefix + =<< prefixWithProgName msg + +-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions +data VerboseException a = VerboseException CallStack POSIXTime Verbosity a + deriving (Show) + +-- Function which will replace the existing die' call sites +dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a +dieWithException verbosity exception = do + ts <- getPOSIXTime + throwIO $ VerboseException callStack ts verbosity exception + +-- Instance for Cabal Exception which will display error code and error message with callStack info +instance Exception (VerboseException CabalException) where + displayException :: VerboseException CabalException -> [Char] + displayException (VerboseException stack timestamp verb cabalexception) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (exceptionCode cabalexception) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (exceptionMessage cabalexception) + +dieNoWrap :: Verbosity -> String -> IO a +dieNoWrap verbosity msg = withFrozenCallStack $ do + -- TODO: should this have program name or not? + ioError . verbatimUserError + =<< annotateErrorString + verbosity + (addErrorPrefix msg) + +-- | Prefixing a message to indicate that it is a fatal error, +-- if the 'errorPrefix' is not already present. +addErrorPrefix :: String -> String +addErrorPrefix msg + | errorPrefix `isPrefixOf` msg = msg + -- Backpack prefixes its errors already with "Error:", see + -- 'Distribution.Utils.LogProgress.dieProgress'. + -- Taking it away there destroys the layout, so we rather + -- check here whether the prefix is already present. + | otherwise = unwords [errorPrefix, msg] + +-- | A prefix indicating that a message is a fatal error. +errorPrefix :: String +errorPrefix = "Error:" + +-- | Prefix an error string with program name from 'getProgName' +prefixWithProgName :: String -> IO String +prefixWithProgName msg = do + pname <- getProgName + return $ pname ++ ": " ++ msg + +-- | Annotate an error string with timestamp and 'withMetadata'. +annotateErrorString :: Verbosity -> String -> IO String +annotateErrorString verbosity msg = do + ts <- getPOSIXTime + return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + +-- | Given a block of IO code that may raise an exception, annotate +-- it with the metadata from the current scope. Use this as close +-- to external code that raises IO exceptions as possible, since +-- this function unconditionally wraps the error message with a trace +-- (so it is NOT idempotent.) +annotateIO :: Verbosity -> IO a -> IO a +annotateIO verbosity act = do + ts <- getPOSIXTime + flip modifyIOError act $ + ioeModifyErrorString $ + withMetadata ts NeverMark VerboseTrace verbosity + +-- | A semantic editor for the error message inside an 'IOError'. +ioeModifyErrorString :: (String -> String) -> IOError -> IOError +ioeModifyErrorString = over ioeErrorString + +-- | A lens for the error message inside an 'IOError'. +ioeErrorString :: Lens' IOError String +ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) + +{-# NOINLINE topHandlerWith #-} +topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a +topHandlerWith cont prog = do + -- By default, stderr to a terminal device is NoBuffering. But this + -- is *really slow* + hSetBuffering stderr LineBuffering + Exception.catches + prog + [ Exception.Handler rethrowAsyncExceptions + , Exception.Handler rethrowExitStatus + , Exception.Handler handle + ] + where + -- Let async exceptions rise to the top for the default top-handler + rethrowAsyncExceptions :: Exception.AsyncException -> IO a + rethrowAsyncExceptions a = throwIO a + + -- ExitCode gets thrown asynchronously too, and we don't want to print it + rethrowExitStatus :: ExitCode -> IO a + rethrowExitStatus = throwIO + + -- Print all other exceptions + handle :: Exception.SomeException -> IO a + handle se = do + hFlush stdout + pname <- getProgName + hPutStr stderr (message pname se) + cont se + + message :: String -> Exception.SomeException -> String + message pname (Exception.SomeException se) = + case cast se :: Maybe Exception.IOException of + Just ioe + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe ++ "\n" + | isUserError ioe -> + let file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n : _) | isDigit n -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail + _ -> + displaySomeException se ++ "\n" + +-- | BC wrapper around 'Exception.displayException'. +displaySomeException :: Exception.Exception e => e -> String +displaySomeException se = Exception.displayException se + +topHandler :: IO a -> IO a +topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog + +-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. +verbosityHandle :: Verbosity -> Handle +verbosityHandle verbosity + | isVerboseStderr verbosity = stderr + | otherwise = stdout + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +warn :: Verbosity -> String -> IO () +warn verbosity msg = warnMessage "Warning" verbosity msg + +-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the +-- the message. Useful when you want to highlight the condition is an error +-- but do not want to quit the program yet. +warnError :: Verbosity -> String -> IO () +warnError verbosity message = warnMessage "Error" verbosity message + +-- | Warning message, with a custom label. +warnMessage :: String -> Verbosity -> String -> IO () +warnMessage l verbosity msg = withFrozenCallStack $ do + when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do + ts <- getPOSIXTime + hFlush stdout + hPutStr stderr + . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ l ++ ": " ++ msg + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +notice :: Verbosity -> String -> IO () +notice verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + +-- | Display a message at 'normal' verbosity level, but without +-- wrapping. +noticeNoWrap :: Verbosity -> String -> IO () +noticeNoWrap verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + +-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity +-- level. Use this if you need fancy formatting. +noticeDoc :: Verbosity -> Disp.Doc -> IO () +noticeDoc verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + Disp.renderStyle defaultStyle $ + msg + +-- | Display a "setup status message". Prefer using setupMessage' +-- if possible. +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = withFrozenCallStack $ do + noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +info :: Verbosity -> String -> IO () +info verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + +infoNoWrap :: Verbosity -> String -> IO () +infoNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +debug :: Verbosity -> String -> IO () +debug verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | A variant of 'debug' that doesn't perform the automatic line +-- wrapping. Produces better output in some cases. +debugNoWrap :: Verbosity -> String -> IO () +debugNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry + :: String + -- ^ a description of the action we were attempting + -> IO () + -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + +-- | Run an IO computation, returning @e@ if it raises a "file +-- does not exist" error. +handleDoesNotExist :: a -> IO a -> IO a +handleDoesNotExist e = + Exception.handleJust + (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) + (\_ -> return e) + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text unless the @+nowrap@ verbosity flag is active +wrapTextVerbosity :: Verbosity -> String -> String +wrapTextVerbosity verb + | isVerboseNoWrap verb = withTrailingNewline + | otherwise = withTrailingNewline . wrapText + +-- | Prepends a timestamp if @+timestamp@ verbosity flag is set +-- +-- This is used by 'withMetadata' +withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp v ts msg + | isVerboseTimestamp v = msg' + | otherwise = msg -- no-op + where + msg' = case lines msg of + [] -> tsstr "\n" + l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest) + + -- format timestamp to be prepended to first line with msec precision + tsstr = showFFloat (Just 3) (realToFrac ts :: Double) + + -- continuation prefix for subsequent lines of msg + contpfx = replicate (length (tsstr " ")) ' ' + +-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. +-- +-- NB: Why is markoutput done with start/end markers, and not prefixes? +-- Markers are more convenient to add (if we want to add prefixes, +-- we have to 'lines' and then 'map'; here's it's just some +-- concatenates). Note that even in the prefix case, we can't +-- guarantee that the markers are unambiguous, because some of +-- Cabal's output comes straight from external programs, where +-- we don't have the ability to interpose on the output. +-- +-- This is used by 'withMetadata' +withOutputMarker :: Verbosity -> String -> String +withOutputMarker v xs | not (isVerboseMarkOutput v) = xs +withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly +withOutputMarker _ xs = + "-----BEGIN CABAL OUTPUT-----\n" + ++ withTrailingNewline xs + ++ "-----END CABAL OUTPUT-----\n" + +-- | Append a trailing newline to a string if it does not +-- already have a trailing newline. +withTrailingNewline :: String -> String +withTrailingNewline "" = "" +withTrailingNewline (x : xs) = x : go x xs + where + go _ (c : cs) = c : go c cs + go '\n' "" = "" + go _ "" = "\n" + +-- | Prepend a call-site and/or call-stack based on Verbosity +withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix tracer verbosity s = + withFrozenCallStack $ + ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( case traceWhen verbosity tracer of + Just pre -> pre ++ prettyCallStack callStack ++ "\n" + Nothing -> "" + ) + ++ s + +-- | When should we emit the call stack? We always emit +-- for internal errors, emit the trace for errors when we +-- are in verbose mode, and otherwise only emit it if +-- explicitly asked for using the @+callstack@ verbosity +-- flag. (At the moment, 'AlwaysTrace' is not used. +data TraceWhen + = AlwaysTrace + | VerboseTrace + | FlagTrace + deriving (Eq) + +-- | Determine if we should emit a call stack. +-- If we trace, it also emits any prefix we should append. +traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen _ AlwaysTrace = Just "" +traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" +traceWhen _ _ = Nothing + +-- | When should we output the marker? Things like 'die' +-- always get marked, but a 'NormalMark' will only be +-- output if we're not a quiet verbosity. +data MarkWhen = AlwaysMark | NormalMark | NeverMark + +-- | Add all necessary metadata to a logging message +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata ts marker tracer verbosity x = + withFrozenCallStack + $ + -- NB: order matters. Output marker first because we + -- don't want to capture call stacks. + withTrailingNewline + . withCallStackPrefix tracer verbosity + . ( case marker of + AlwaysMark -> withOutputMarker verbosity + NormalMark + | not (isVerboseQuiet verbosity) -> + withOutputMarker verbosity + | otherwise -> + id + NeverMark -> id + ) + -- Clear out any existing markers + . clearMarkers + . withTimestamp verbosity ts + $ x + +-- | Add all necessary metadata to a logging message +exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String +exceptionWithMetadata stack ts verbosity x = + withTrailingNewline + . exceptionWithCallStackPrefix stack verbosity + . withOutputMarker verbosity + . clearMarkers + . withTimestamp verbosity ts + $ x + +clearMarkers :: String -> String +clearMarkers s = unlines . filter isMarker $ lines s + where + isMarker "-----BEGIN CABAL OUTPUT-----" = False + isMarker "-----END CABAL OUTPUT-----" = False + isMarker _ = True + +-- | Append a call-site and/or call-stack based on Verbosity +exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String +exceptionWithCallStackPrefix stack verbosity s = + s + ++ withFrozenCallStack + ( ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( if verbosity >= verbose + then prettyCallStack stack ++ "\n" + else "" + ) + ) + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +-- +-- These all use 'Distribution.Compat.Process.proc' to ensure we +-- consistently use process jobs on Windows and Ctrl-C delegation +-- on Unix. +-- +-- Additionally, they take care of logging command execution. +-- + +-- | Helper to use with one of the 'rawSystem' variants, and exit +-- unless the command completes successfully. +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + exitcode <- cmd + unless (exitcode == ExitSuccess) $ exitWith exitcode + +-- | Log a command execution (that's typically about to happen) +-- at info level, and log working directory and environment overrides +-- at debug level if specified. +logCommand :: Verbosity -> Process.CreateProcess -> IO () +logCommand verbosity cp = do + infoNoWrap verbosity $ + "Running: " <> case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path args -> Process.showCommandForUser path args + case Process.env cp of + Just env -> debugNoWrap verbosity $ "with environment: " ++ show env + Nothing -> return () + case Process.cwd cp of + Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd + Nothing -> return () + hFlush stdout + +-- | Execute the given command with the given arguments, exiting +-- with the same exit code if the command fails. +rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO () +rawSystemExit verbosity mbWorkDir path args = + withFrozenCallStack $ + maybeExit $ + rawSystemExitCode verbosity mbWorkDir path args Nothing + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +rawSystemExitCode + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> FilePath + -> [String] + -> Maybe [(String, String)] + -> IO ExitCode +rawSystemExitCode verbosity mbWorkDir path args menv = + withFrozenCallStack $ + rawSystemProc verbosity $ + (proc path args) + { Process.cwd = fmap getSymbolicPath mbWorkDir + , Process.env = menv + } + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +-- +-- Create the process argument with 'Distribution.Compat.Process.proc' +-- to ensure consistent options with other 'rawSystem' functions in this +-- module. +rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode +rawSystemProc verbosity cp = withFrozenCallStack $ do + (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return () + return exitcode + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. 'action' is executed while the command +-- is running, and would typically be used to communicate with the +-- process through pipes. +-- +-- Create the process argument with 'Distribution.Compat.Process.proc' +-- to ensure consistent options with other 'rawSystem' functions in this +-- module. +rawSystemProcAction + :: Verbosity + -> Process.CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) + -> IO (ExitCode, a) +rawSystemProcAction verbosity cp action = withFrozenCallStack $ do + logCommand verbosity cp + (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do + a <- action mStdin mStdout mStderr + exitcode <- Process.waitForProcess p + return (exitcode, a) + unless (exitcode == ExitSuccess) $ do + let cmd = case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path _args -> path + debug verbosity $ cmd ++ " returned " ++ show exitcode + return (exitcode, a) + +-- | fromJust for dealing with 'Maybe Handle' values as obtained via +-- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees +-- a 'Just' value for the corresponding handle. +fromCreatePipe :: Maybe Handle -> Handle +fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id + +-- | Execute the given command with the given arguments and +-- environment, exiting with the same exit code if the command fails. +rawSystemExitWithEnv + :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity = + rawSystemExitWithEnvCwd verbosity Nothing + +-- | Like 'rawSystemExitWithEnv', but setting a working directory. +rawSystemExitWithEnvCwd + :: Verbosity + -> Maybe (SymbolicPath CWD to) + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnvCwd verbosity mbWorkDir path args env = + withFrozenCallStack $ + maybeExit $ + rawSystemProc verbosity $ + (proc path args) + { Process.env = Just env + , Process.cwd = getSymbolicPath <$> mbWorkDir + } + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +-- +-- Optional arguments allow setting working directory, environment +-- and input and output handles. +rawSystemIOWithEnv + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do + (exitcode, _) <- + rawSystemIOWithEnvAndAction + verbosity + path + args + mcwd + menv + action + inp + out + err + return exitcode + where + action = return () + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. 'action' is executed while the command +-- is running, and would typically be used to communicate with the +-- process through pipes. +-- +-- Optional arguments allow setting working directory, environment +-- and input and output handles. +rawSystemIOWithEnvAndAction + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> IO a + -- ^ action to perform after process is created, but before 'waitForProcess'. + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO (ExitCode, a) +rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = mbToStd inp + , Process.std_out = mbToStd out + , Process.std_err = mbToStd err + } + rawSystemProcAction verbosity cp (\_ _ _ -> action) + where + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle + +-- | Execute the given command with the given arguments, returning +-- the command's output. Exits if the command exits with error. +-- +-- Provides control over the binary/text mode of the output. +rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode +rawSystemStdout verbosity path args = withFrozenCallStack $ do + (output, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + Nothing + Nothing + Nothing + (IOData.iodataMode :: IODataMode mode) + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + RawSystemStdout errors + return output + +-- | Execute the given command with the given arguments, returning +-- the command's output, errors and exit code. +-- +-- Optional arguments allow setting working directory, environment +-- and command input. +-- +-- Provides control over the binary/text mode of the input and output. +rawSystemStdInOut + :: KnownIODataMode mode + => Verbosity + -> FilePath + -- ^ Program location + -> [String] + -- ^ Arguments + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe IOData + -- ^ input text and binary mode + -> IODataMode mode + -- ^ iodata mode, acts as proxy + -> IO (mode, String, ExitCode) + -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do + let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err) + flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do + -- output mode depends on what the caller wants + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do + -- push all the input, if any + ignoreSigPipe $ case input of + Nothing -> hClose inh + Just inputData -> IOData.hPutContents inh inputData + + -- wait for both to finish + mberr1 <- waitCatch outA + mberr2 <- waitCatch errA + return (mberr1, mberr2) + + -- get the stderr, so it can be added to error message + err <- reportOutputIOError mberr2 + + unless (exitcode == ExitSuccess) $ + debug verbosity $ + path + ++ " returned " + ++ show exitcode + ++ if null err + then "" + else + " with error message:\n" + ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + + -- Check if we hit an exception while consuming the output + -- (e.g. a text decoding error) + out <- reportOutputIOError mberr1 + + return (out, err, exitcode) + where + reportOutputIOError :: Either Exception.SomeException a -> IO a + reportOutputIOError (Right x) = return x + reportOutputIOError (Left exc) = case fromException exc of + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc + +-- | Ignore SIGPIPE in a subcomputation. +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = Exception.handle $ \case + GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe} + | Errno ioe == ePIPE -> return () + e -> throwIO e + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +findProgramVersion + :: String + -- ^ version args + -> (String -> String) + -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath + -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do + str <- + rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catch` (\(_ :: VerboseException CabalException) -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParsec (selectVersion str) + case version of + Nothing -> + warn verbosity $ + "cannot determine version of " + ++ path + ++ " :\n" + ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v + return version + +-- | Like the Unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +xargs + :: Int + -> ([String] -> IO ()) + -> [String] + -> [String] + -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + where + chunks len = unfoldr $ \s -> + if null s + then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc, []) + chunk acc len (s : ss) + | len' < len = chunk (s : acc) (len - len' - 1) ss + | otherwise = (reverse acc, s : ss) + where + len' = length s + +-- ------------------------------------------------------------ + +-- * File Utilities + +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +-- @since 3.4.0.0 +findFileCwd + :: forall searchDir allowAbsolute + . Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ search directories + -> RelativePath searchDir File + -- ^ File Name + -> IO (SymbolicPathX allowAbsolute Pkg File) +findFileCwd verbosity mbWorkDir searchPath fileName = + findFirstFile + (interpretSymbolicPath mbWorkDir) + [ path fileName + | path <- ordNub searchPath + ] + >>= maybe (dieWithException verbosity $ FindFile $ getSymbolicPath fileName) return + +-- | Find a file by looking in a search path. The file path must match exactly. +findFileEx + :: forall searchDir allowAbsolute + . Verbosity + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ search directories + -> RelativePath searchDir File + -- ^ File Name + -> IO (SymbolicPathX allowAbsolute Pkg File) +findFileEx v = findFileCwd v Nothing + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +findFileWithExtension + :: [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File)) +findFileWithExtension = + findFileCwdWithExtension Nothing + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. +-- +-- @since 3.4.0.0 +findFileCwdWithExtension + :: forall searchDir allowAbsolute + . Maybe (SymbolicPath CWD (Dir Pkg)) + -> [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File)) +findFileCwdWithExtension cwd extensions searchPath baseName = + fmap (uncurry ()) + <$> findFileCwdWithExtension' cwd extensions searchPath baseName + +-- | @since 3.4.0.0 +findAllFilesCwdWithExtension + :: forall searchDir allowAbsolute + . Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> [Suffix] + -- ^ extensions + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ relative search locations + -> RelativePath searchDir File + -- ^ basename + -> IO [SymbolicPathX allowAbsolute Pkg File] +findAllFilesCwdWithExtension mbWorkDir extensions searchPath basename = + findAllFiles + (interpretSymbolicPath mbWorkDir) + [ path basename <.> ext + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +findAllFilesWithExtension + :: [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO [SymbolicPathX allowAbsolute Pkg File] +findAllFilesWithExtension = + findAllFilesCwdWithExtension Nothing + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +findFileWithExtension' + :: [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)) +findFileWithExtension' = + findFileCwdWithExtension' Nothing + +-- | Like 'findFileCwdWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +findFileCwdWithExtension' + :: forall searchDir allowAbsolute + . Maybe (SymbolicPath CWD (Dir Pkg)) + -> [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)) +findFileCwdWithExtension' cwd extensions searchPath baseName = + findFirstFile + (uncurry mkPath) + [ (path, baseName <.> ext) + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + where + mkPath :: SymbolicPathX allowAbsolute Pkg (Dir searchDir) -> RelativePath searchDir File -> FilePath + mkPath base file = + interpretSymbolicPath cwd (base file) + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where + findFirst [] = return Nothing + findFirst (x : xs) = do + exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +findAllFiles :: (a -> FilePath) -> [a] -> IO [a] +findAllFiles file = filterM (doesFileExist . file) + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +findModuleFilesEx + :: forall searchDir allowAbsolute + . Verbosity + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> [ModuleName] + -- ^ modules + -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)] +findModuleFilesEx verbosity searchPath extensions moduleNames = + traverse (findModuleFileEx verbosity searchPath extensions) moduleNames + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFileCwd' but for a list of module names. +findModuleFilesCwd + :: forall searchDir allowAbsolute + . Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> [ModuleName] + -- ^ modules + -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)] +findModuleFilesCwd verbosity cwd searchPath extensions moduleNames = + traverse (findModuleFileCwd verbosity cwd searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +findModuleFileEx + :: forall searchDir allowAbsolute + . Verbosity + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> ModuleName + -- ^ module + -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File) +findModuleFileEx verbosity = + findModuleFileCwd verbosity Nothing + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileCwdWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +findModuleFileCwd + :: forall searchDir allowAbsolute + . Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> ModuleName + -- ^ module + -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File) +findModuleFileCwd verbosity cwd searchPath extensions mod_name = do + mbRes <- + findFileCwdWithExtension' + cwd + extensions + searchPath + (makeRelativePathEx $ ModuleName.toFilePath mod_name) + case mbRes of + Nothing -> + dieWithException verbosity $ + FindModuleFileEx mod_name extensions (map getSymbolicPath searchPath) + Just res -> return res + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + where + collect files dirs' [] = + return + ( reverse files + , reverse dirs' + ) + collect files dirs' (entry : entries) + | ignore entry = + collect files dirs' entries + collect files dirs' (entry : entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry : dirs') entries + else collect (dirEntry : files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +------------------------ +-- Environment variables + +-- | Is this directory in the system search path? +isInSearchPath :: FilePath -> IO Bool +isInSearchPath path = fmap (elem path) getSearchPath + +addLibraryPath + :: OS + -> [FilePath] + -> [(String, String)] + -> [(String, String)] +addLibraryPath os paths = addEnv + where + pathsString = intercalate [searchPathSeparator] paths + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + _ -> "LD_LIBRARY_PATH" + + addEnv [] = [(ldPath, pathsString)] + addEnv ((key, value) : xs) + | key == ldPath = + if null value + then (key, pathsString) : xs + else (key, value ++ (searchPathSeparator : pathsString)) : xs + | otherwise = (key, value) : addEnv xs + +-------------------- +-- Modification time + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do + tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +createDirectoryIfMissingVerbose + :: Verbosity + -> Bool + -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = withFrozenCallStack $ createDirs (parents path0) + | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir : []) = createDir dir throwIO + createDirs (dir : dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exception in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> + ( do + isDir <- doesDirectoryExist dir + unless isDir $ throwIO e + ) + `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = withFrozenCallStack $ do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = withFrozenCallStack $ do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Install a file that may or not be executable, preserving permissions. +installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do + perms <- getPermissions src + if (executable perms) -- only checks user x bit + then installExecutableFile verbosity src dest + else installOrdinaryFile verbosity src dest + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileTo + :: Verbosity + -> FilePath + -> FilePath + -> IO () +copyFileTo verbosity dir file = + withFrozenCallStack $ + copyFileToCwd + verbosity + Nothing + (makeSymbolicPath dir) + (makeRelativePathEx file) + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileToCwd + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir target) + -> RelativePath Pkg File + -> IO () +copyFileToCwd verbosity mbWorkDir dir file = withFrozenCallStack $ do + let targetFile = i $ dir unsafeCoerceSymbolicPath file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity (i file) targetFile + where + i :: SymbolicPathX allowAbs Pkg to -> FilePath + i = interpretSymbolicPath mbWorkDir + +-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', +-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. +copyFilesWith + :: (Verbosity -> FilePath -> FilePath -> IO ()) + -> Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do + -- Create parent directories for everything + let dirs = map (targetDir ) . ordNub . map (takeDirectory . snd) $ srcFiles + traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ + [ let src = srcBase srcFile + dest = targetDir srcFile + in doCopy verbosity src dest + | (srcBase, srcFile) <- srcFiles + ] + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installExecutableFile'. +installExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. +installMaybeExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles] + +-- | Recursively copy the contents of one directory to another path. +copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFilesWith + (const copyFile) + verbosity + destDir + [ (srcDir, f) + | f <- srcFiles + ] + +------------------- +-- File permissions + +-- | Like 'doesFileExist', but also checks that the file is executable. +doesExecutableExist :: FilePath -> IO Bool +doesExecutableExist f = do + exists <- doesFileExist f + if exists + then do + perms <- getPermissions f + return (executable perms) + else return False + +--------------------------- +-- Temporary files and dirs + +-- | Advanced options for 'withTempFile' and 'withTempDirectory'. +data TempFileOptions = TempFileOptions + { optKeepTempFiles :: Bool + -- ^ Keep temporary files? + } + +defaultTempFileOptions :: TempFileOptions +defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False} + +-- | Use a temporary filename that doesn't already exist +withTempFile + :: String + -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) + -> IO a +withTempFile template f = withFrozenCallStack $ + withTempFileCwd template $ + \fp h -> f (getSymbolicPath fp) h + +-- | Use a temporary filename that doesn't already exist. +withTempFileCwd + :: String + -- ^ File name template. See 'openTempFile'. + -> (SymbolicPath Pkg File -> Handle -> IO a) + -> IO a +withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions + +-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' +-- argument. +withTempFileEx + :: forall a + . TempFileOptions + -> String + -- ^ File name template. See 'openTempFile'. + -> (SymbolicPath Pkg File -> Handle -> IO a) + -> IO a +withTempFileEx opts template action = do + tmp <- getTemporaryDirectory + withFrozenCallStack $ + Exception.bracket + (openTempFile tmp template) + ( \(name, handle) -> do + hClose handle + unless (optKeepTempFiles opts) $ + handleDoesNotExist () $ + removeFile $ + name + ) + (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) + where + mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File + mkRelToPkg tmp fp = + makeSymbolicPath tmp makeRelativePathEx (takeFileName fp) + +-- 'openTempFile' returns a path of the form @i tmpDir fn@, but we +-- want 'withTempFileEx' to return @tmpDir fn@. So we split off +-- the filename and add back the (un-interpreted) directory. +-- This assumes 'openTempFile' returns a filepath of the form +-- @inputDir fn@, where @fn@ does not contain any path separators. + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory + :: Verbosity + -> FilePath + -> String + -> (FilePath -> IO a) + -> IO a +withTempDirectory verb targetDir template f = + withFrozenCallStack $ + withTempDirectoryCwd + verb + Nothing + (makeSymbolicPath targetDir) + template + (f . getSymbolicPath) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectoryCwd + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir tmpDir1) + -> String + -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) + -> IO a +withTempDirectoryCwd verbosity mbWorkDir targetDir template f = + withFrozenCallStack $ + withTempDirectoryCwdEx + verbosity + defaultTempFileOptions + mbWorkDir + targetDir + template + (withLexicalCallStack (\x -> f x)) + +-- | A version of 'withTempDirectory' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryEx + :: Verbosity + -> TempFileOptions + -> FilePath + -> String + -> (FilePath -> IO a) + -> IO a +withTempDirectoryEx verbosity opts targetDir template f = + withFrozenCallStack $ + withTempDirectoryCwdEx verbosity opts Nothing (makeSymbolicPath targetDir) template $ + \fp -> f (getSymbolicPath fp) + +-- | A version of 'withTempDirectoryCwd' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryCwdEx + :: forall a tmpDir1 tmpDir2 + . Verbosity + -> TempFileOptions + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir tmpDir1) + -> String + -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) + -> IO a +withTempDirectoryCwdEx _verbosity opts mbWorkDir targetDir template f = + withFrozenCallStack $ + Exception.bracket + (createTempDirectory (i targetDir) template) + ( \tmpDirRelPath -> + unless (optKeepTempFiles opts) $ + handleDoesNotExist () $ + removeDirectoryRecursive (i targetDir tmpDirRelPath) + ) + (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir makeRelativePathEx tmpDirRelPath)) + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + +----------------------------------- +-- Safely reading and writing files + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +-- NB: Before Cabal-3.0 the file content was assumed to be +-- ASCII-representable. Since Cabal-3.0 the file is assumed to be +-- UTF-8 encoded. +rewriteFileEx :: Verbosity -> FilePath -> String -> IO () +rewriteFileEx verbosity path = + rewriteFileLBS verbosity path . toUTF8LBS + +-- | Same as `rewriteFileEx` but for 'ByteString's. +rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () +rewriteFileLBS verbosity path newContent = + flip catchIO mightNotExist $ do + existingContent <- annotateIO verbosity $ BS.readFile path + _ <- evaluate (BS.length existingContent) + unless (existingContent == newContent) $ + annotateIO verbosity $ + writeFileAtomic path newContent + where + mightNotExist e + | isDoesNotExistError e = + annotateIO verbosity $ writeFileAtomic path newContent + | otherwise = + ioError e + +shortRelativePath :: FilePath -> FilePath -> FilePath +shortRelativePath from to = + case dropCommonPrefix (splitDirectories from) (splitDirectories to) of + (stuff, path) -> joinPath (map (const "..") stuff ++ path) + where + dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) + dropCommonPrefix (x : xs) (y : ys) + | x == y = dropCommonPrefix xs ys + dropCommonPrefix xs ys = (xs, ys) + +-- | Drop the extension if it's one of 'exeExtensions', or return the path +-- unchanged. +dropExeExtension :: FilePath -> FilePath +dropExeExtension filepath = + -- System.FilePath's extension handling functions are horribly + -- inconsistent, consider: + -- + -- isExtensionOf "" "foo" == False but + -- isExtensionOf "" "foo." == True. + -- + -- On the other hand stripExtension doesn't remove the empty extension: + -- + -- stripExtension "" "foo." == Just "foo." + -- + -- Since by "" in exeExtensions we mean 'no extension' anyways we can + -- just always ignore it here. + let exts = [ext | ext <- exeExtensions, ext /= ""] + in fromMaybe filepath $ do + ext <- find (`FilePath.isExtensionOf` filepath) exts + ext `FilePath.stripExtension` filepath + +-- | List of possible executable file extensions on the current build +-- platform. +exeExtensions :: [String] +exeExtensions = case (buildArch, buildOS) of + -- Possible improvement: on Windows, read the list of extensions from the + -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; + -- .cmd". + -- + -- See also #10179. + -- + -- Also we cannot actually run @.bat@ files as we do now, because of + -- https://github.com/haskell/process/issues/140. If we detect one of those, + -- we should record that the program is a script and run a @Process.shell@ instead + -- of a @Process.proc@. + (_, Windows) -> ["", "exe"] + (_, Ghcjs) -> ["", "exe"] + (Wasm32, _) -> ["", "wasm"] + _ -> [""] + +-- ------------------------------------------------------------ + +-- * Finding the description file + +-- ------------------------------------------------------------ + +-- | Package description file (/pkgname/@.cabal@) in the current +-- working directory. +defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg File) +defaultPackageDescCwd verbosity = tryFindPackageDesc verbosity Nothing + +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ package directory + -> IO (Either CabalException (RelativePath Pkg File)) +findPackageDesc mbPkgDir = + do + let pkgDir = maybe "." getSymbolicPath mbPkgDir + files <- getDirectoryContents pkgDir + -- to make sure we do not mistake a ~/.cabal/ dir for a .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/TestSuite.hs b/src/Distribution/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/TestSuite.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the detailed test suite interface which makes it +-- possible to expose individual tests to Cabal or other test agents. +module Distribution.TestSuite + ( TestInstance (..) + , OptionDescr (..) + , OptionType (..) + , Test (..) + , Options + , Progress (..) + , Result (..) + , testGroup + ) where + +import Distribution.Compat.Prelude +import Prelude () + +data TestInstance = TestInstance + { run :: IO Progress + -- ^ Perform the test. + , name :: String + -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] + -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] + -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } + +data OptionDescr = OptionDescr + { optionName :: String + , optionDescription :: String + -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } + deriving (Eq, Read, Show) + +data OptionType + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed + deriving (Eq, Read, Show) + +data Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test + +type Options = [(String, String)] + +data Progress + = Finished Result + | Progress String (IO Progress) + +data Result + = Pass + | Fail String + | Error String + deriving (Eq, Read, Show) + +-- | Create a named group of tests, which are assumed to be safe to run in +-- parallel. +testGroup :: String -> [Test] -> Test +testGroup n ts = Group{groupName = n, concurrently = True, groupTests = ts} diff --git a/src/Distribution/Types/AnnotatedId.hs b/src/Distribution/Types/AnnotatedId.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/AnnotatedId.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Distribution.Types.AnnotatedId + ( AnnotatedId (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Package +import Distribution.Types.ComponentName + +-- | An 'AnnotatedId' is a 'ComponentId', 'UnitId', etc. +-- which is annotated with some other useful information +-- that is useful for printing to users, etc. +-- +-- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y +-- and ann_cname x == ann_cname y +data AnnotatedId id = AnnotatedId + { ann_pid :: PackageId + , ann_cname :: ComponentName + , ann_id :: id + } + deriving (Show, Functor) + +instance Eq id => Eq (AnnotatedId id) where + x == y = ann_id x == ann_id y + +instance Ord id => Ord (AnnotatedId id) where + compare x y = compare (ann_id x) (ann_id y) + +instance Package (AnnotatedId id) where + packageId = ann_pid diff --git a/src/Distribution/Types/ComponentInclude.hs b/src/Distribution/Types/ComponentInclude.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/ComponentInclude.hs @@ -0,0 +1,32 @@ +module Distribution.Types.ComponentInclude + ( ComponentInclude (..) + , ci_id + , ci_pkgid + , ci_cname + ) where + +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.PackageId + +-- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', +-- the 'includeRequiresRn' is not so useful (because it +-- includes the requirements renaming that is no longer +-- needed); use 'ci_prov_renaming' instead. +data ComponentInclude id rn = ComponentInclude + { ci_ann_id :: AnnotatedId id + , ci_renaming :: rn + , ci_implicit :: Bool + -- ^ Did this come from an entry in @mixins@, or + -- was implicitly generated by @build-depends@? + } + +ci_id :: ComponentInclude id rn -> id +ci_id = ann_id . ci_ann_id + +ci_pkgid :: ComponentInclude id rn -> PackageId +ci_pkgid = ann_pid . ci_ann_id + +-- | This should always return 'CLibName' or 'CSubLibName' +ci_cname :: ComponentInclude id rn -> ComponentName +ci_cname = ann_cname . ci_ann_id diff --git a/src/Distribution/Types/ComponentLocalBuildInfo.hs b/src/Distribution/Types/ComponentLocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/ComponentLocalBuildInfo.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Types.ComponentLocalBuildInfo + ( ComponentLocalBuildInfo (..) + , componentIsIndefinite + , maybeComponentInstantiatedWith + , maybeComponentCompatPackageKey + , maybeComponentExposedModules + ) where + +import Distribution.Compat.Prelude +import Distribution.ModuleName +import Prelude () + +import Distribution.Backpack +import Distribution.Compat.Graph +import Distribution.Types.ComponentId +import Distribution.Types.ComponentName +import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId + +import qualified Distribution.InstalledPackageInfo as Installed + +-- | The first five fields are common across all algebraic variants. +data ComponentLocalBuildInfo + = LibComponentLocalBuildInfo + { componentLocalName :: ComponentName + -- ^ It would be very convenient to store the literal Library here, + -- but if we do that, it will get serialized (via the Binary) + -- instance twice. So instead we just provide the ComponentName, + -- which can be used to find the Component in the + -- PackageDescription. NB: eventually, this will NOT uniquely + -- identify the ComponentLocalBuildInfo. + , componentComponentId :: ComponentId + -- ^ The computed 'ComponentId' of this component. + , componentUnitId :: UnitId + -- ^ The computed 'UnitId' which uniquely identifies this + -- component. Might be hashed. + , componentIsIndefinite_ :: Bool + -- ^ Is this an indefinite component (i.e. has unfilled holes)? + , componentInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the component was instantiated + , componentPackageDeps :: [(UnitId, MungedPackageId)] + -- ^ Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + -- ^ The set of packages that are brought into scope during + -- compilation, including a 'ModuleRenaming' which may used + -- to hide or rename modules. This is what gets translated into + -- @-package-id@ arguments. This is a modernized version of + -- 'componentPackageDeps', which is kept around for BC purposes. + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + -- ^ The internal dependencies which induce a graph on the + -- 'ComponentLocalBuildInfo' of this package. This does NOT + -- coincide with 'componentPackageDeps' because it ALSO records + -- 'build-tool' dependencies on executables. Maybe one day + -- @cabal-install@ will also handle these correctly too! + , componentCompatPackageKey :: String + -- ^ Compatibility "package key" that we pass to older versions of GHC. + , componentCompatPackageName :: MungedPackageName + -- ^ Compatibility "package name" that we register this component as. + , componentExposedModules :: [Installed.ExposedModule] + -- ^ A list of exposed modules (either defined in this component, + -- or reexported from another component.) + , componentIsPublic :: Bool + -- ^ Convenience field, specifying whether or not this is the + -- "public library" that has the same name as the package. + } + | -- TODO: refactor all these duplicates + FLibComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | ExeComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | TestComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | BenchComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + deriving (Generic, Read, Show) + +instance Binary ComponentLocalBuildInfo +instance Structured ComponentLocalBuildInfo + +instance IsNode ComponentLocalBuildInfo where + type Key ComponentLocalBuildInfo = UnitId + nodeKey = componentUnitId + nodeNeighbors = componentInternalDeps + +componentIsIndefinite :: ComponentLocalBuildInfo -> Bool +componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b +componentIsIndefinite _ = False + +maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] +maybeComponentInstantiatedWith + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts +maybeComponentInstantiatedWith _ = Nothing + +maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String +maybeComponentCompatPackageKey + LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key +maybeComponentCompatPackageKey _ = Nothing + +maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule] +maybeComponentExposedModules + LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed +maybeComponentExposedModules _ = Nothing 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/GivenComponent.hs b/src/Distribution/Types/GivenComponent.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/GivenComponent.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.GivenComponent + ( GivenComponent (..) + , PromisedComponent (..) + ) where + +import Distribution.Compat.Prelude + +import Distribution.Types.ComponentId +import Distribution.Types.LibraryName +import Distribution.Types.PackageId +import Distribution.Types.PackageName + +-- | A 'GivenComponent' represents a library depended on and explicitly +-- specified by the user/client with @--dependency@ +-- +-- It enables Cabal to know which 'ComponentId' to associate with a library +-- +-- @since 2.3.0.0 +data GivenComponent = GivenComponent + { givenComponentPackage :: PackageName + , givenComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , givenComponentId :: ComponentId + } + deriving (Generic, Read, Show, Eq) + +instance Binary GivenComponent +instance Structured GivenComponent + +-- | A 'PromisedComponent' represents a promised library depended on and explicitly +-- specified by the user/client with @--promised-dependency@ +-- +-- It enables Cabal to know which 'ComponentId' to associate with a library +-- +-- @since 3.14.0.0 +data PromisedComponent = PromisedComponent + { promisedComponentPackage :: PackageId + , promisedComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , promisedComponentId :: ComponentId + } + deriving (Generic, Read, Show, Eq) + +instance Binary PromisedComponent +instance Structured PromisedComponent 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/LocalBuildInfo.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Types.LocalBuildInfo + ( -- * The types + LocalBuildInfo + ( LocalBuildInfo + , configFlags + , flagAssignment + , componentEnabledSpec + , extraConfigArgs + , installDirTemplates + , compiler + , hostPlatform + , pkgDescrFile + , componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + , localPkgDescr + , withPrograms + , withPackageDB + , withVanillaLib + , withProfLib + , withProfLibShared + , withDynExe + , withFullyStaticExe + , withProfExe + , withSharedLib + , withStaticLib + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , extraCoverageFor + , relocatable + , .. + ) + + -- * Convenience accessors + , localComponentId + , localUnitId + , localCompatPackageKey + , localPackage + , buildDir + , buildDirPBD + , setupFlagsBuildDir + , distPrefLBI + , packageRoot + , progPrefix + , progSuffix + + -- * Build targets of the 'LocalBuildInfo'. + , componentNameCLBIs + -- NB: the primes mean that they take a 'PackageDescription' + -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. + -- More logical types would drop this argument, but + -- at the moment, this is the ONLY supported function, because + -- 'localPkgDescr' is not guaranteed to match. At some point + -- we will fix it and then we can use the (free) unprimed + -- namespace for the correct commands. + -- + -- See https://github.com/haskell/cabal/issues/3606 for more + -- details. + + , componentNameTargets' + , unitIdTarget' + , allTargetsInBuildOrder' + , withAllTargetsInBuildOrder' + , neededTargetsInBuildOrder' + , withNeededTargetsInBuildOrder' + , testCoverage + , buildWays + + -- * Functions you SHOULD NOT USE (yet), but are defined here to + + -- prevent someone from accidentally defining them + + , componentNameTargets + , unitIdTarget + , allTargetsInBuildOrder + , withAllTargetsInBuildOrder + , neededTargetsInBuildOrder + , withNeededTargetsInBuildOrder + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ComponentId +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.GivenComponent +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.PackageDescription +import Distribution.Types.PackageId +import Distribution.Types.TargetInfo +import Distribution.Types.UnitId + +import Distribution.Utils.Path + +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.BuildWay +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.System + +import qualified Data.Map as Map +import Distribution.Compat.Graph (Graph) +import qualified Distribution.Compat.Graph as Graph + +import qualified System.FilePath as FilePath (takeDirectory) + +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. +data LocalBuildInfo = NewLocalBuildInfo + { localBuildDescr :: LBC.LocalBuildDescr + -- ^ Information about a package determined by Cabal + -- after the configuration step. + , localBuildConfig :: LBC.LocalBuildConfig + -- ^ Information about a package configuration + -- that can be modified by the user at configuration time. + } + deriving (Generic, Read, Show) + +{-# COMPLETE LocalBuildInfo #-} + +-- | This pattern synonym is for backwards compatibility, to adapt +-- to 'LocalBuildInfo' being split into 'LocalBuildDescr' and 'LocalBuildConfig'. +pattern LocalBuildInfo + :: ConfigFlags + -> FlagAssignment + -> ComponentRequestedSpec + -> [String] + -> InstallDirTemplates + -> Compiler + -> Platform + -> Maybe (SymbolicPath Pkg File) + -> Graph ComponentLocalBuildInfo + -> Map ComponentName [ComponentLocalBuildInfo] + -> Map (PackageName, ComponentName) PromisedComponent + -> InstalledPackageIndex + -> PackageDescription + -> ProgramDb + -> PackageDBStack + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> ProfDetailLevel + -> ProfDetailLevel + -> OptimisationLevel + -> DebugInfoLevel + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> [UnitId] + -> Bool + -> LocalBuildInfo +pattern LocalBuildInfo + { configFlags + , flagAssignment + , componentEnabledSpec + , extraConfigArgs + , installDirTemplates + , compiler + , hostPlatform + , pkgDescrFile + , componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + , localPkgDescr + , withPrograms + , withPackageDB + , withVanillaLib + , withProfLib + , withProfLibShared + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , extraCoverageFor + , relocatable + } = + NewLocalBuildInfo + { localBuildDescr = + LBC.LocalBuildDescr + { packageBuildDescr = + LBC.PackageBuildDescr + { configFlags + , flagAssignment + , componentEnabledSpec + , compiler + , hostPlatform + , localPkgDescr + , installDirTemplates + , withPackageDB + , pkgDescrFile + , extraCoverageFor + } + , componentBuildDescr = + LBC.ComponentBuildDescr + { componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + } + } + , localBuildConfig = + LBC.LocalBuildConfig + { extraConfigArgs + , withPrograms + , withBuildOptions = + LBC.BuildOptions + { withVanillaLib + , withProfLib + , withProfLibShared + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , relocatable + } + } + } + +instance Binary LocalBuildInfo +instance Structured LocalBuildInfo + +------------------------------------------------------------------------------- +-- Accessor functions + +buildDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Build) +buildDir lbi = + buildDirPBD $ LBC.packageBuildDescr $ localBuildDescr lbi + +buildDirPBD :: LBC.PackageBuildDescr -> SymbolicPath Pkg (Dir Build) +buildDirPBD (LBC.PackageBuildDescr{configFlags = cfg}) = + setupFlagsBuildDir $ configCommonFlags cfg + +setupFlagsBuildDir :: CommonSetupFlags -> SymbolicPath Pkg (Dir Build) +setupFlagsBuildDir cfg = fromFlag (setupDistPref cfg) makeRelativePathEx "build" + +distPrefLBI :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) +distPrefLBI = fromFlag . setupDistPref . configCommonFlags . LBC.configFlags . LBC.packageBuildDescr . localBuildDescr + +-- | The (relative or absolute) path to the package root, based on +-- +-- - the working directory flag +-- - the @.cabal@ path +packageRoot :: CommonSetupFlags -> FilePath +packageRoot cfg = + case flagToMaybe (setupCabalFilePath cfg) of + Just cabalPath -> FilePath.takeDirectory $ interpretSymbolicPath mbWorkDir cabalPath + Nothing -> maybe "." getSymbolicPath mbWorkDir + where + mbWorkDir = flagToMaybe $ setupWorkingDir cfg + +progPrefix, progSuffix :: LocalBuildInfo -> PathTemplate +progPrefix (LocalBuildInfo{configFlags = cfg}) = + fromFlag $ configProgPrefix cfg +progSuffix (LocalBuildInfo{configFlags = cfg}) = + fromFlag $ configProgSuffix cfg + +-- TODO: Get rid of these functions, as much as possible. They are +-- a bit useful in some cases, but you should be very careful! + +-- | Extract the 'ComponentId' from the public library component of a +-- 'LocalBuildInfo' if it exists, or make a fake component ID based +-- on the package ID. +localComponentId :: LocalBuildInfo -> ComponentId +localComponentId lbi = + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentComponentId = cid}] -> + cid + _ -> mkComponentId (prettyShow (localPackage lbi)) + +-- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. +-- This is a "safe" use of 'localPkgDescr' +localPackage :: LocalBuildInfo -> PackageId +localPackage (LocalBuildInfo{localPkgDescr = pkg}) = package pkg + +-- | Extract the 'UnitId' from the library component of a +-- 'LocalBuildInfo' if it exists, or make a fake unit ID based on +-- the package ID. +localUnitId :: LocalBuildInfo -> UnitId +localUnitId lbi = + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentUnitId = uid}] -> + uid + _ -> mkLegacyUnitId $ localPackage lbi + +-- | Extract the compatibility package key from the public library component of a +-- 'LocalBuildInfo' if it exists, or make a fake package key based +-- on the package ID. +localCompatPackageKey :: LocalBuildInfo -> String +localCompatPackageKey lbi = + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] -> + pk + _ -> prettyShow (localPackage lbi) + +-- | Convenience function to generate a default 'TargetInfo' from a +-- 'ComponentLocalBuildInfo'. The idea is to call this once, and then +-- use 'TargetInfo' everywhere else. Private to this module. +mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo +mkTargetInfo pkg_descr _lbi clbi = + TargetInfo + { targetCLBI = clbi + , -- NB: @pkg_descr@, not @localPkgDescr lbi@! + targetComponent = + getComponent + pkg_descr + (componentLocalName clbi) + } + +-- | Return all 'TargetInfo's associated with 'ComponentName'. +-- In the presence of Backpack there may be more than one! +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo] +componentNameTargets' pkg_descr lbi@(LocalBuildInfo{componentNameMap = comps}) cname = + case Map.lookup cname comps of + Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis + Nothing -> [] + +unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo +unitIdTarget' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uid = + case Graph.lookup uid compsGraph of + Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) + Nothing -> Nothing + +-- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. +-- In the presence of Backpack there may be more than one! +componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] +componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname = + case Map.lookup cname comps of + Just clbis -> clbis + Nothing -> [] + +-- TODO: Maybe cache topsort (Graph can do this) + +-- | Return the list of default 'TargetInfo's associated with a +-- configured package, in the order they need to be built. +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo] +allTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) = + map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort compsGraph) + +-- | Execute @f@ for every 'TargetInfo' in the package, respecting the +-- build dependency order. (TODO: We should use Shake!) +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () +withAllTargetsInBuildOrder' pkg_descr lbi f = + sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi] + +-- | Return the list of all targets needed to build the @uids@, in +-- the order they need to be built. +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids = + case Graph.closure compsGraph uids of + Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) + Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) + +-- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting +-- the build dependency order. +-- Has a prime because it takes a 'PackageDescription' argument +-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. +withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () +withNeededTargetsInBuildOrder' pkg_descr lbi uids f = + sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids] + +-- | Is coverage enabled for test suites? In practice, this requires library +-- and executable profiling to be enabled. +testCoverage :: LocalBuildInfo -> Bool +testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) = + exes && libs + +-- | Returns a list of ways, in the order which they should be built, and the +-- way we build executable and foreign library components. +-- +-- Ideally all this info should be fixed at configure time and not dependent on +-- additional info but `LocalBuildInfo` is per package (not per component) so it's +-- currently not possible to configure components to be built in certain ways. +buildWays :: LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) +buildWays lbi = + let + -- enable-library-profiling (enable (static profiling way)) .p_o + -- enable-shared (enabled dynamic way) .dyn_o + -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o + -- enable-library-vanilla (enable vanilla way) .o + -- + -- enable-executable-dynamic => build dynamic executables + -- => --enable-profiling + --enable-executable-dynamic => build dynamic profiled executables + -- => --enable-profiling => build vanilla profiled executables + + wantedLibWays is_indef = + [ProfDynWay | withProfLibShared lbi && not is_indef] + <> [ProfWay | withProfLib lbi] + -- I don't see why we shouldn't build with dynamic-- indefinite components. + <> [DynWay | withSharedLib lbi && not is_indef] + -- MP: Ideally we should have `BuildOptions` on a per component basis, in + -- which case this `is_indef` check could be moved to configure time. + <> [StaticWay | withVanillaLib lbi || withStaticLib lbi] + + wantedFLibWay is_dyn_flib = + case (is_dyn_flib, withProfExe lbi) of + (True, True) -> ProfDynWay + (False, True) -> ProfWay + (True, False) -> DynWay + (False, False) -> StaticWay + + wantedExeWay = + case (withDynExe lbi, withProfExe lbi) of + (True, True) -> ProfDynWay + (True, False) -> DynWay + (False, True) -> ProfWay + (False, False) -> StaticWay + in + (wantedLibWays, wantedFLibWay, wantedExeWay) + +------------------------------------------------------------------------------- +-- Stub functions to prevent someone from accidentally defining them + +{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} +componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] +componentNameTargets lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + componentNameTargets' pkg lbi +unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo +unitIdTarget lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + unitIdTarget' pkg lbi +allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] +allTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + allTargetsInBuildOrder' pkg lbi +withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () +withAllTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + withAllTargetsInBuildOrder' pkg lbi +neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + neededTargetsInBuildOrder' pkg lbi +withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () +withNeededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + withNeededTargetsInBuildOrder' pkg lbi diff --git a/src/Distribution/Types/PackageName/Magic.hs b/src/Distribution/Types/PackageName/Magic.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/PackageName/Magic.hs @@ -0,0 +1,24 @@ +-- | Magic 'PackageName's. +-- +-- @since 3.0.0.0 +module Distribution.Types.PackageName.Magic where + +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.Version + +-- | Used as a placeholder in "Distribution.Backpack.ReadyComponent" +nonExistentPackageThisIsCabalBug :: PackageName +nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug" + +-- | Used by @cabal new-repl@, @cabal new-run@ and @cabal new-build@ +fakePackageName :: PackageName +fakePackageName = mkPackageName "fake-package" + +-- | Used by @cabal new-run@ and @cabal new-build@ +fakePackageCabalFileName :: FilePath +fakePackageCabalFileName = "fake-package.cabal" + +-- | 'fakePackageName' with 'version0'. +fakePackageId :: PackageId +fakePackageId = PackageIdentifier fakePackageName version0 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/TargetInfo.hs b/src/Distribution/Types/TargetInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/TargetInfo.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Types.TargetInfo + ( TargetInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.UnitId + +import Distribution.Compat.Graph (IsNode (..)) + +-- | The 'TargetInfo' contains all the information necessary to build a +-- specific target (e.g., component/module/file) in a package. In +-- principle, one can get the 'Component' from a +-- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more +-- convenient to have the component in hand. +data TargetInfo = TargetInfo + { targetCLBI :: ComponentLocalBuildInfo + , targetComponent :: Component + -- TODO: BuildTargets supporting parsing these is dumb, + -- we don't have support for compiling single modules or + -- file paths. Accommodating it now is premature + -- generalization. Figure it out later. + -- targetSub :: Maybe (Either ModuleName FilePath) + } + deriving (Generic, Show) + +instance Binary TargetInfo +instance Structured TargetInfo + +instance IsNode TargetInfo where + type Key TargetInfo = UnitId + nodeKey = nodeKey . targetCLBI + nodeNeighbors = nodeNeighbors . targetCLBI diff --git a/src/Distribution/Utils/IOData.hs b/src/Distribution/Utils/IOData.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/IOData.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +-- | @since 2.2.0 +module Distribution.Utils.IOData + ( -- * 'IOData' & 'IODataMode' type + IOData (..) + , IODataMode (..) + , KnownIODataMode (..) + , withIOData + , null + , hPutContents + ) where + +import qualified Data.ByteString.Lazy as LBS +import Distribution.Compat.Prelude hiding (null) +import qualified System.IO +import qualified Prelude + +-- | Represents either textual or binary data passed via I/O functions +-- which support binary/text mode +-- +-- @since 2.2 +data IOData + = -- | How Text gets encoded is usually locale-dependent. + IODataText String + | -- | Raw binary which gets read/written in binary mode. + IODataBinary LBS.ByteString + +-- | Applies a function polymorphic over 'IODataMode' to an 'IOData' value. +withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r +withIOData (IODataText str) k = k IODataModeText str +withIOData (IODataBinary lbs) k = k IODataModeBinary lbs + +-- | Test whether 'IOData' is empty +null :: IOData -> Bool +null (IODataText s) = Prelude.null s +null (IODataBinary b) = LBS.null b + +instance NFData IOData where + rnf (IODataText s) = rnf s + rnf (IODataBinary lbs) = rnf lbs + +-- | @since 2.2 +class NFData mode => KnownIODataMode mode where + -- | 'IOData' Wrapper for 'System.IO.hGetContents' + -- + -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all + -- data to be read and consequently the internal file handle to be + -- closed. + hGetIODataContents :: System.IO.Handle -> Prelude.IO mode + + toIOData :: mode -> IOData + iodataMode :: IODataMode mode + +-- | Phantom-typed GADT representation of the mode of 'IOData', containing no +-- other data. +-- +-- @since 3.2 +data IODataMode mode where + IODataModeText :: IODataMode String + IODataModeBinary :: IODataMode LBS.ByteString + +instance a ~ Char => KnownIODataMode [a] where + hGetIODataContents h = do + System.IO.hSetBinaryMode h False + System.IO.hGetContents h + + toIOData = IODataText + iodataMode = IODataModeText + +instance KnownIODataMode LBS.ByteString where + hGetIODataContents h = do + System.IO.hSetBinaryMode h True + LBS.hGetContents h + + toIOData = IODataBinary + iodataMode = IODataModeBinary + +-- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' +-- +-- This is the dual operation to 'hGetIODataContents', +-- and consequently the handle is closed with `hClose`. +-- +-- /Note:/ this performs lazy-IO. +-- +-- @since 2.2 +hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () +hPutContents h (IODataText c) = do + System.IO.hSetBinaryMode h False + System.IO.hPutStr h c + System.IO.hClose h +hPutContents h (IODataBinary c) = do + System.IO.hSetBinaryMode h True + LBS.hPutStr h c + System.IO.hClose h 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 new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/LogProgress.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + +module Distribution.Utils.LogProgress + ( LogProgress + , runLogProgress + , warnProgress + , infoProgress + , dieProgress + , addProgressCtx + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Utils +import Distribution.Utils.Progress +import Distribution.Verbosity +import Text.PrettyPrint + +type CtxMsg = Doc +type LogMsg = Doc +type ErrMsg = Doc + +data LogEnv = LogEnv + { le_verbosity :: Verbosity + , le_context :: [CtxMsg] + } + +-- | The 'Progress' monad with specialized logging and +-- error messages. +newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a} + +instance Functor LogProgress where + fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) + +instance Applicative LogProgress where + pure x = LogProgress (pure (pure x)) + LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r + +instance Monad LogProgress where + return = pure + LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r + +-- | Run 'LogProgress', outputting traces according to 'Verbosity', +-- 'die' if there is an error. +runLogProgress :: Verbosity -> LogProgress a -> IO a +runLogProgress verbosity (LogProgress m) = + foldProgress step_fn fail_fn return (m env) + where + env = + LogEnv + { le_verbosity = verbosity + , le_context = [] + } + step_fn :: LogMsg -> IO a -> IO a + step_fn doc go = do + putStrLn (render doc) + go + fail_fn :: Doc -> IO a + fail_fn doc = do + dieNoWrap verbosity (render doc) + +-- | Output a warning trace message in 'LogProgress'. +warnProgress :: Doc -> LogProgress () +warnProgress s = LogProgress $ \env -> + when (le_verbosity env >= normal) $ + stepProgress $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) + +-- | Output an informational trace message in 'LogProgress'. +infoProgress :: Doc -> LogProgress () +infoProgress s = LogProgress $ \env -> + when (le_verbosity env >= verbose) $ + stepProgress s + +-- | Fail the computation with an error message. +dieProgress :: Doc -> LogProgress a +dieProgress s = LogProgress $ \env -> + failProgress $ + hang (text "Error:") 4 (formatMsg (le_context env) s) + +-- | Format a message with context. (Something simple for now.) +formatMsg :: [CtxMsg] -> Doc -> Doc +formatMsg ctx doc = doc $$ vcat ctx + +-- | Add a message to the error/warning context. +addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a +addProgressCtx s (LogProgress m) = LogProgress $ \env -> + m env{le_context = s : le_context env} diff --git a/src/Distribution/Utils/MapAccum.hs b/src/Distribution/Utils/MapAccum.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/MapAccum.hs @@ -0,0 +1,26 @@ +module Distribution.Utils.MapAccum (mapAccumM) where + +import Distribution.Compat.Prelude +import Prelude () + +-- Like StateT but with return tuple swapped +newtype StateM s m a = StateM {runStateM :: s -> m (s, a)} + +instance Functor m => Functor (StateM s m) where + fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) + +instance Monad m => Applicative (StateM s m) where + pure x = StateM $ \s -> return (s, x) + StateM f <*> StateM x = StateM $ \s -> do + (s', f') <- f s + (s'', x') <- x s' + return (s'', f' x') + +-- | Monadic variant of 'mapAccumL'. +mapAccumM + :: (Monad m, Traversable t) + => (a -> b -> m (a, c)) + -> a + -> t b + -> m (a, t c) +mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s diff --git a/src/Distribution/Utils/NubList.hs b/src/Distribution/Utils/NubList.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/NubList.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Utils.NubList + ( NubList -- opaque + , toNubList -- smart constructor + , fromNubList + , overNubList + , NubListR + , toNubListR + , fromNubListR + , overNubListR + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Utils + +import qualified Text.Read as R + +-- | NubList : A de-duplicated list that maintains the original order. +newtype NubList a = NubList {fromNubList :: [a]} + deriving (Eq, Generic) + +-- NubList assumes that nub retains the list order while removing duplicate +-- elements (keeping the first occurrence). Documentation for "Data.List.nub" +-- does not specifically state that ordering is maintained so we will add a test +-- for that to the test suite. + +-- | Smart constructor for the NubList type. +toNubList :: Ord a => [a] -> NubList a +toNubList list = NubList $ ordNub list + +-- | Lift a function over lists to a function over NubLists. +overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a +overNubList f (NubList list) = toNubList . f $ list + +-- | Monoid operations on NubLists. +-- For a valid Monoid instance we need to satisfy the required monoid laws; +-- identity, associativity and closure. +-- +-- Identity : by inspection: +-- mempty `mappend` NubList xs == NubList xs `mappend` mempty +-- +-- Associativity : by inspection: +-- (NubList xs `mappend` NubList ys) `mappend` NubList zs +-- == NubList xs `mappend` (NubList ys `mappend` NubList zs) +-- +-- Closure : appending two lists of type a and removing duplicates obviously +-- does not change the type. +instance Ord a => Monoid (NubList a) where + mempty = NubList [] + mappend = (<>) + +instance Ord a => Semigroup (NubList a) where + (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys + +instance Show a => Show (NubList a) where + show (NubList list) = show list + +instance (Ord a, Read a) => Read (NubList a) where + readPrec = readNubList toNubList + +-- | Helper used by NubList/NubListR's Read instances. +readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a) +readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec + +-- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we +-- just pull off constructor and put the list. For 'get', we get the list and +-- make a 'NubList' out of it using 'toNubList'. +instance (Ord a, Binary a) => Binary (NubList a) where + put (NubList l) = put l + get = fmap toNubList get + +instance Structured a => Structured (NubList a) + +-- | NubListR : A right-biased version of 'NubList'. That is @toNubListR +-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, +-- unlike the normal 'NubList', which is left-biased. Built on top of +-- 'ordNubRight' and 'listUnionRight'. +newtype NubListR a = NubListR {fromNubListR :: [a]} + deriving (Eq) + +-- | Smart constructor for the NubListR type. +toNubListR :: Ord a => [a] -> NubListR a +toNubListR list = NubListR $ ordNubRight list + +-- | Lift a function over lists to a function over NubListRs. +overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a +overNubListR f (NubListR list) = toNubListR . f $ list + +instance Ord a => Monoid (NubListR a) where + mempty = NubListR [] + mappend = (<>) + +instance Ord a => Semigroup (NubListR a) where + (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys + +instance Show a => Show (NubListR a) where + show (NubListR list) = show list + +instance (Ord a, Read a) => Read (NubListR a) where + readPrec = readNubList toNubListR diff --git a/src/Distribution/Utils/Progress.hs b/src/Distribution/Utils/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/Progress.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- Note: This module was copied from cabal-install. + +-- | A progress monad, which we use to report failure and logging from +-- otherwise pure code. +module Distribution.Utils.Progress + ( Progress + , stepProgress + , failProgress + , foldProgress + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Data.Monoid as Mon + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail (or maybe not expensive, but complicated!) +-- We may get intermediate steps before the final +-- result which may be used to indicate progress and\/or logging messages. +-- +-- TODO: Apply Codensity to avoid left-associativity problem. +-- See http://comonad.com/reader/2011/free-monads-for-less/ and +-- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ +data Progress step fail done + = Step step (Progress step fail done) + | Fail fail + | Done done + deriving (Functor) + +-- | Emit a step and then continue. +stepProgress :: step -> Progress step fail () +stepProgress step = Step step (Done ()) + +-- | Fail the computation. +failProgress :: fail -> Progress step fail done +failProgress err = Fail err + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +foldProgress + :: (step -> a -> a) + -> (fail -> a) + -> (done -> a) + -> Progress step fail done + -> a +foldProgress step err done = fold + where + fold (Step s p) = step s (fold p) + fold (Fail f) = err f + fold (Done r) = done r + +instance Monad (Progress step fail) where + return = pure + p >>= f = foldProgress Step Fail f p + +instance Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail Mon.mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/src/Distribution/Utils/UnionFind.hs b/src/Distribution/Utils/UnionFind.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/UnionFind.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +-- | A simple mutable union-find data structure. +-- +-- It is used in a unification algorithm for backpack mix-in linking. +-- +-- This implementation is based off of the one in \"The Essence of ML Type +-- Inference\". (N.B. the union-find package is also based off of this.) +module Distribution.Utils.UnionFind + ( Point + , fresh + , find + , union + , equivalent + ) where + +import Control.Monad +import Control.Monad.ST +import Data.STRef + +-- | A variable which can be unified; alternately, this can be thought +-- of as an equivalence class with a distinguished representative. +newtype Point s a = Point (STRef s (Link s a)) + deriving (Eq) + +-- | Mutable write to a 'Point' +writePoint :: Point s a -> Link s a -> ST s () +writePoint (Point v) = writeSTRef v + +-- | Read the current value of 'Point'. +readPoint :: Point s a -> ST s (Link s a) +readPoint (Point v) = readSTRef v + +-- | The internal data structure for a 'Point', which either records +-- the representative element of an equivalence class, or a link to +-- the 'Point' that actually stores the representative type. +data Link s a + = -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) + +-- | Create a fresh equivalence class with one element. +fresh :: a -> ST s (Point s a) +fresh desc = do + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) + +-- | Flatten any chains of links, returning a 'Point' +-- which points directly to the canonical representation. +repr :: Point s a -> ST s (Point s a) +repr point = + readPoint point >>= \r -> + case r of + Link point' -> do + point'' <- repr point' + when (point'' /= point') $ do + writePoint point =<< readPoint point' + return point'' + Info _ _ -> return point + +-- | Return the canonical element of an equivalence +-- class 'Point'. +find :: Point s a -> ST s a +find point = + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> + readPoint point' >>= \r' -> + case r' of + Info _ d_ref -> readSTRef d_ref + Link _ -> repr point >>= find + +-- | Unify two equivalence classes, so that they share +-- a canonical element. Keeps the descriptor of point2. +union :: Point s a -> Point s a -> ST s () +union refpoint1 refpoint2 = do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do + l1 <- readPoint point1 + l2 <- readPoint point2 + case (l1, l2) of + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" + +-- | Test if two points are in the same equivalence class. +equivalent :: Point s a -> Point s a -> ST s Bool +equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2) diff --git a/src/Distribution/Verbosity.hs b/src/Distribution/Verbosity.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Verbosity.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- + +-- Verbosity for Cabal functions. + +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A 'Verbosity' type with associated utilities. +-- +-- There are 4 standard verbosity levels from 'silent', 'normal', +-- 'verbose' up to 'deafening'. This is used for deciding what logging +-- messages to print. +-- +-- Verbosity also is equipped with some internal settings which can be +-- used to control at a fine granularity the verbosity of specific +-- settings (e.g., so that you can trace only particular things you +-- are interested in.) It's important to note that the instances +-- for 'Verbosity' assume that this does not exist. +module Distribution.Verbosity + ( -- * Verbosity + Verbosity + , silent + , normal + , verbose + , deafening + , moreVerbose + , lessVerbose + , isVerboseQuiet + , intToVerbosity + , flagToVerbosity + , showForCabal + , showForGHC + , verboseNoFlags + , verboseHasFlags + , modifyVerbosity + + -- * Call stacks + , verboseCallSite + , verboseCallStack + , isVerboseCallSite + , isVerboseCallStack + + -- * Output markets + , verboseMarkOutput + , isVerboseMarkOutput + , verboseUnmarkOutput + + -- * Line wrapping + , verboseNoWrap + , isVerboseNoWrap + + -- * Time stamps + , verboseTimestamp + , isVerboseTimestamp + , verboseNoTimestamp + + -- * Stderr + , verboseStderr + , isVerboseStderr + , verboseNoStderr + + -- * No warnings + , verboseNoWarn + , isVerboseNoWarn + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ReadE + +import Data.List (elemIndex) +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Generic (isAsciiAlpha) +import Distribution.Verbosity.Internal + +import qualified Data.Set as Set +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data Verbosity = Verbosity + { vLevel :: VerbosityLevel + , vFlags :: Set VerbosityFlag + , vQuiet :: Bool + } + deriving (Generic, Show, Read) + +mkVerbosity :: VerbosityLevel -> Verbosity +mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} + +instance Eq Verbosity where + x == y = vLevel x == vLevel y + +instance Ord Verbosity where + compare x y = compare (vLevel x) (vLevel y) + +instance Enum Verbosity where + toEnum = mkVerbosity . toEnum + fromEnum = fromEnum . vLevel + +instance Bounded Verbosity where + minBound = mkVerbosity minBound + maxBound = mkVerbosity maxBound + +instance Binary Verbosity +instance Structured Verbosity + +-- | In 'silent' mode, we should not print /anything/ unless an error occurs. +silent :: Verbosity +silent = mkVerbosity Silent + +-- | Print stuff we want to see by default. +normal :: Verbosity +normal = mkVerbosity Normal + +-- | Be more verbose about what's going on. +verbose :: Verbosity +verbose = mkVerbosity Verbose + +-- | Not only are we verbose ourselves (perhaps even noisier than when +-- being 'verbose'), but we tell everything we run to be verbose too. +deafening :: Verbosity +deafening = mkVerbosity Deafening + +-- | Increase verbosity level, but stay 'silent' if we are. +moreVerbose :: Verbosity -> Verbosity +moreVerbose v = + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v{vLevel = Verbose} + Verbose -> v{vLevel = Deafening} + Deafening -> v + +-- | Decrease verbosity level, but stay 'deafening' if we are. +lessVerbose :: Verbosity -> Verbosity +lessVerbose v = + verboseQuiet $ + case vLevel v of + Deafening -> v -- deafening stays deafening + Verbose -> v{vLevel = Normal} + Normal -> v{vLevel = Silent} + Silent -> v + +-- | Combinator for transforming verbosity level while retaining the +-- original hidden state. +-- +-- For instance, the following property holds +-- +-- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v +-- +-- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite +-- @v1@'s flags with @v0@'s flags. +-- +-- @since 2.0.1.0 +modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity +modifyVerbosity f v = v{vLevel = vLevel (f v)} + +-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just (mkVerbosity Silent) +intToVerbosity 1 = Just (mkVerbosity Normal) +intToVerbosity 2 = Just (mkVerbosity Verbose) +intToVerbosity 3 = Just (mkVerbosity Deafening) +intToVerbosity _ = Nothing + +-- | Parser verbosity +-- +-- >>> explicitEitherParsec parsecVerbosity "normal" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap " +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput" +-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- +-- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack" +-- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) +-- +-- /Note:/ this parser will eat trailing spaces. +instance Parsec Verbosity where + parsec = parsecVerbosity + +instance Pretty Verbosity where + pretty = PP.text . showForCabal + +parsecVerbosity :: CabalParsing m => m Verbosity +parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity + where + parseIntVerbosity = do + i <- P.integral + case intToVerbosity i of + Just v -> return v + Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" + + parseStringVerbosity = do + level <- parseVerbosityLevel + _ <- P.spaces + flags <- many (parseFlag <* P.spaces) + return $ foldl' (flip ($)) (mkVerbosity level) flags + + parseVerbosityLevel = do + token <- P.munch1 isAsciiAlpha + case token of + "silent" -> return Silent + "normal" -> return Normal + "verbose" -> return Verbose + "debug" -> return Deafening + "deafening" -> return Deafening + _ -> P.unexpected $ "Bad verbosity level: " ++ token + parseFlag = do + _ <- P.char '+' + token <- P.munch1 isAsciiAlpha + case token of + "callsite" -> return verboseCallSite + "callstack" -> return verboseCallStack + "nowrap" -> return verboseNoWrap + "markoutput" -> return verboseMarkOutput + "timestamp" -> return verboseTimestamp + "stderr" -> return verboseStderr + "stdout" -> return verboseNoStderr + "nowarn" -> return verboseNoWarn + _ -> P.unexpected $ "Bad verbosity flag: " ++ token + +flagToVerbosity :: ReadE Verbosity +flagToVerbosity = parsecToReadE id parsecVerbosity + +showForCabal :: Verbosity -> String +showForCabal v + | Set.null (vFlags v) = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, verbose, deafening] + | otherwise = + unwords $ + showLevel (vLevel v) + : concatMap showFlag (Set.toList (vFlags v)) + where + showLevel Silent = "silent" + showLevel Normal = "normal" + showLevel Verbose = "verbose" + showLevel Deafening = "debug" + + showFlag VCallSite = ["+callsite"] + showFlag VCallStack = ["+callstack"] + showFlag VNoWrap = ["+nowrap"] + showFlag VMarkOutput = ["+markoutput"] + showFlag VTimestamp = ["+timestamp"] + showFlag VStderr = ["+stderr"] + showFlag VNoWarn = ["+nowarn"] + +showForGHC :: Verbosity -> String +showForGHC v = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, __, verbose, deafening] + where + __ = silent -- this will be always ignored by elemIndex + +-- | Turn on verbose call-site printing when we log. +verboseCallSite :: Verbosity -> Verbosity +verboseCallSite = verboseFlag VCallSite + +-- | Turn on verbose call-stack printing when we log. +verboseCallStack :: Verbosity -> Verbosity +verboseCallStack = verboseFlag VCallStack + +-- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output +-- from Cabal (as opposed to GHC, or system dependent). +verboseMarkOutput :: Verbosity -> Verbosity +verboseMarkOutput = verboseFlag VMarkOutput + +-- | Turn off marking; useful for suppressing nondeterministic output. +verboseUnmarkOutput :: Verbosity -> Verbosity +verboseUnmarkOutput = verboseNoFlag VMarkOutput + +-- | Disable line-wrapping for log messages. +verboseNoWrap :: Verbosity -> Verbosity +verboseNoWrap = verboseFlag VNoWrap + +-- | Mark the verbosity as quiet. +verboseQuiet :: Verbosity -> Verbosity +verboseQuiet v = v{vQuiet = True} + +-- | Turn on timestamps for log messages. +verboseTimestamp :: Verbosity -> Verbosity +verboseTimestamp = verboseFlag VTimestamp + +-- | Turn off timestamps for log messages. +verboseNoTimestamp :: Verbosity -> Verbosity +verboseNoTimestamp = verboseNoFlag VTimestamp + +-- | Switch logging to 'stderr'. +-- +-- @since 3.4.0.0 +verboseStderr :: Verbosity -> Verbosity +verboseStderr = verboseFlag VStderr + +-- | Switch logging to 'stdout'. +-- +-- @since 3.4.0.0 +verboseNoStderr :: Verbosity -> Verbosity +verboseNoStderr = verboseNoFlag VStderr + +-- | Turn off warnings for log messages. +verboseNoWarn :: Verbosity -> Verbosity +verboseNoWarn = verboseFlag VNoWarn + +-- | Helper function for flag enabling functions. +verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) +verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} + +-- | Helper function for flag disabling functions. +verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) +verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} + +-- | Turn off all flags. +verboseNoFlags :: Verbosity -> Verbosity +verboseNoFlags v = v{vFlags = Set.empty} + +verboseHasFlags :: Verbosity -> Bool +verboseHasFlags = not . Set.null . vFlags + +-- | Test if we should output call sites when we log. +isVerboseCallSite :: Verbosity -> Bool +isVerboseCallSite = isVerboseFlag VCallSite + +-- | Test if we should output call stacks when we log. +isVerboseCallStack :: Verbosity -> Bool +isVerboseCallStack = isVerboseFlag VCallStack + +-- | Test if we should output markets. +isVerboseMarkOutput :: Verbosity -> Bool +isVerboseMarkOutput = isVerboseFlag VMarkOutput + +-- | Test if line-wrapping is disabled for log messages. +isVerboseNoWrap :: Verbosity -> Bool +isVerboseNoWrap = isVerboseFlag VNoWrap + +-- | Test if we had called 'lessVerbose' on the verbosity. +isVerboseQuiet :: Verbosity -> Bool +isVerboseQuiet = vQuiet + +-- | Test if we should output timestamps when we log. +isVerboseTimestamp :: Verbosity -> Bool +isVerboseTimestamp = isVerboseFlag VTimestamp + +-- | Test if we should output to 'stderr' when we log. +-- +-- @since 3.4.0.0 +isVerboseStderr :: Verbosity -> Bool +isVerboseStderr = isVerboseFlag VStderr + +-- | Test if we should output warnings when we log. +isVerboseNoWarn :: Verbosity -> Bool +isVerboseNoWarn = isVerboseFlag VNoWarn + +-- | Helper function for flag testing functions. +isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool +isVerboseFlag flag = (Set.member flag) . vFlags + +-- $setup +-- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) +-- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum +-- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary diff --git a/src/Distribution/Verbosity/Internal.hs b/src/Distribution/Verbosity/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Verbosity/Internal.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Verbosity.Internal + ( VerbosityLevel (..) + , VerbosityFlag (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +data VerbosityLevel = Silent | Normal | Verbose | Deafening + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) + +instance Binary VerbosityLevel +instance Structured VerbosityLevel + +data VerbosityFlag + = VCallStack + | VCallSite + | VNoWrap + | VMarkOutput + | VTimestamp + | -- | @since 3.4.0.0 + VStderr + | VNoWarn + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) + +instance Binary VerbosityFlag +instance Structured VerbosityFlag diff --git a/src/Distribution/ZinzaPrelude.hs b/src/Distribution/ZinzaPrelude.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ZinzaPrelude.hs @@ -0,0 +1,44 @@ +-- | A small prelude used in @zinza@ generated +-- template modules. +module Distribution.ZinzaPrelude + ( Writer + , execWriter + , tell + + -- * Re-exports + , forM_ + , Generic + , PackageName + , Version + , prettyShow + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad (forM_) +import Distribution.Pretty (prettyShow) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.Version (Version) + +newtype Writer a = W {unW :: ShowS -> (ShowS, a)} + +instance Functor Writer where + fmap = liftM + +instance Applicative Writer where + pure x = W $ \ss -> (ss, x) + (<*>) = ap + +instance Monad Writer where + return = pure + m >>= k = W $ \s1 -> + let (s2, x) = unW m s1 + in unW (k x) s2 + {-# INLINE (>>=) #-} + +execWriter :: Writer a -> String +execWriter w = fst (unW w id) "" + +tell :: String -> Writer () +tell s = W $ \s' -> (s' . showString s, ())