diff --git a/.github/dependabot.yml b/.github/dependabot.yml
index 4a5d80876f7..1b1a5864dec 100644
--- a/.github/dependabot.yml
+++ b/.github/dependabot.yml
@@ -18,3 +18,8 @@ updates:
patterns:
- "*"
+ - package-ecosystem: "uv"
+ directory: "/doc"
+ schedule:
+ interval: "weekly"
+
diff --git a/.github/mergify.yml b/.github/mergify.yml
index a156519462b..2dd788482e8 100644
--- a/.github/mergify.yml
+++ b/.github/mergify.yml
@@ -8,11 +8,13 @@ priority_rules:
- 'label=priority: high :fire:'
priority: 3000
+ allow_checks_interruption: true
- name: priority for queue `default`
conditions:
- queue-name=default
priority: 2500
+ allow_checks_interruption: true
- name: priority for queue `squash-merge`
conditions:
- queue-name=squash-merge
@@ -20,12 +22,14 @@ priority_rules:
# The idea is we slightly prioritize those PRs because we're in
# a release cycle if a PR matches.
+ allow_checks_interruption: true
- name: release branch
conditions:
- 'base~=^3\.'
- 'label!=backport'
priority: 2750
+ allow_checks_interruption: true
pull_request_rules:
# implementing PR delay logic: apply a label after 2 days of inactivity
diff --git a/.github/workflows/bootstrap.yml b/.github/workflows/bootstrap.yml
index 5527e3ea4c8..23a33400253 100644
--- a/.github/workflows/bootstrap.yml
+++ b/.github/workflows/bootstrap.yml
@@ -19,7 +19,7 @@ jobs:
strategy:
matrix:
os: [ubuntu-latest]
- ghc: ["9.2.8", "9.4.8", "9.6.7", "9.8.4", "9.10.2", "9.12.2"]
+ ghc: ["9.2.8", "9.4.8", "9.6.7", "9.8.4", "9.10.3", "9.12.2"]
include:
- os: macos-latest
ghc: "9.2.8"
@@ -32,6 +32,8 @@ jobs:
rm -rf ~/.config/cabal
rm -rf ~/.cache/cabal
+ - uses: actions/checkout@v6
+
# runner.os isn't sufficient for binary compatible caches
- name: Get runner OS/version for cache keys
id: get-osver
@@ -42,10 +44,9 @@ jobs:
id: bootstrap-cache
with:
path: "/home/runner/work/cabal/cabal/_build"
- key: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-20221115-${{ github.sha }}
- restore-keys: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-20221115-
+ key: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-${{ hashFiles(format('bootstrap/linux-{0}.json', matrix.ghc)) }}-${{ github.sha }}
+ restore-keys: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-${{ hashFiles(format('bootstrap/linux-{0}.json', matrix.ghc)) }}-
- - uses: actions/checkout@v6
- uses: haskell-actions/setup@v2
with:
ghc-version: ${{ matrix.ghc }}
diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml
index cbba5b4620e..5df06c0ed7e 100644
--- a/.github/workflows/format.yml
+++ b/.github/workflows/format.yml
@@ -10,7 +10,7 @@ jobs:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v6
- - uses: haskell-actions/run-fourmolu@v11
+ - uses: haskell-actions/run-fourmolu@v12
with:
version: "0.12.0.0"
pattern: |
diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml
index 06a0258e955..4a22ce8515b 100644
--- a/.github/workflows/release.yaml
+++ b/.github/workflows/release.yaml
@@ -79,7 +79,7 @@ jobs:
shell: bash
- name: Release
- uses: softprops/action-gh-release@v2
+ uses: softprops/action-gh-release@v3
with:
draft: true
files: |
diff --git a/.github/workflows/reusable-release.yml b/.github/workflows/reusable-release.yml
index bb81a95e170..81cf9db0aa2 100644
--- a/.github/workflows/reusable-release.yml
+++ b/.github/workflows/reusable-release.yml
@@ -8,7 +8,7 @@ on:
type: string
ghc:
type: string
- default: 9.10.2
+ default: 9.10.3
# speed up installation by skipping docs
# starting with GHC 9.10.x, we also need to pass the 'install_extra' target
ghc_targets:
@@ -24,9 +24,10 @@ on:
env:
GHC_VERSION: ${{ inputs.ghc }}
GHC_TARGETS: ${{ inputs.ghc_targets }}
- # This shouldn't be necessary, but cabal developers
- # want to build with 9.10.2, which causes test failures
- # when used as runtime GHC version as well.
+ # This shouldn't be necessary, but cabal developers want to build with 9.10.3,
+ # which causes test failures when used as runtime GHC version as well. For
+ # more detail, please see the note and link to the issue in
+ # .github/scripts/test.bash
GHC_TEST_VERSION: 9.6.7
GHC_TEST_TARGETS: "install_bin install_lib update_package_db"
CABAL_VERSION: ${{ inputs.cabal }}
diff --git a/.github/workflows/validate.yml b/.github/workflows/validate.yml
index 6e2758a2ce1..b4b9e4775bf 100644
--- a/.github/workflows/validate.yml
+++ b/.github/workflows/validate.yml
@@ -32,10 +32,10 @@ on:
env:
# We choose a stable ghc version across all os's
# which will be used to do the next release
- GHC_FOR_RELEASE: "9.10.2"
+ GHC_FOR_RELEASE: "9.10.3"
# Ideally we should use the version about to be released for hackage tests and benchmarks
- GHC_FOR_SOLVER_BENCHMARKS: "9.10.2"
- GHC_FOR_COMPLETE_HACKAGE_TESTS: "9.10.2"
+ GHC_FOR_SOLVER_BENCHMARKS: "9.10.3"
+ GHC_FOR_COMPLETE_HACKAGE_TESTS: "9.10.3"
COMMON_FLAGS: "-j 2 -v"
# See https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#hackage-revisions
@@ -61,8 +61,8 @@ jobs:
# Also a removed GHC from here means that we are actually dropping
# support, so the PR *must* have a changelog entry.
"9.14.1",
- "9.12.2",
- "9.10.2",
+ "9.12.4",
+ "9.10.3",
"9.8.4",
"9.6.7",
"9.4.8",
diff --git a/.gitignore b/.gitignore
index 1b1ae7e9dc2..e51603a115e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -80,6 +80,7 @@ testdb/intree/store/*/incoming/alex-*.lock
testdb/intree/store/*/incoming/lx-*.lock
testdb/intree/store/*/package.db/package.cache
testdb/intree/store/*/package.db/package.cache.lock
+testdb/intree/store/ghc-*/
# windows test artifacts
cabal-testsuite/**/*.exe
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 2afe14bdcbe..e5d2c7e930a 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -5,7 +5,7 @@ variables:
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: "be4ac2cd18f38e63b263e2a27c76a7c279385796"
- GHC_VERSION: 9.10.2
+ GHC_VERSION: 9.10.3
CABAL_INSTALL_VERSION: 3.14.2.0
workflow:
diff --git a/.hlint.yaml b/.hlint.yaml
index 2c058e5766a..e5672ae408a 100644
--- a/.hlint.yaml
+++ b/.hlint.yaml
@@ -1,49 +1,43 @@
# Warnings currently triggered by your code
- ignore: {name: "Avoid NonEmpty.unzip"} # 1 hint
-- ignore: {name: "Avoid lambda"} # 51 hints
-- ignore: {name: "Avoid lambda using `infix`"} # 23 hints
-- ignore: {name: "Eta reduce"} # 138 hints
-- ignore: {name: "Functor law"} # 10 hints
+- ignore: {name: "Avoid lambda"} # 49 hints
+- ignore: {name: "Eta reduce"} # 139 hints
- ignore: {name: "Hoist not"} # 16 hints
-- ignore: {name: "Monoid law, left identity"} # 3 hints
-- ignore: {name: "Monoid law, right identity"} # 3 hints
- ignore: {name: "Move filter"} # 4 hints
-- ignore: {name: "Move guards forward"} # 5 hints
- ignore: {name: "Redundant $!"} # 1 hint
-- ignore: {name: "Redundant <$>"} # 17 hints
-- ignore: {name: "Redundant bracket"} # 257 hints
-- ignore: {name: "Redundant guard"} # 2 hints
+- ignore: {name: "Redundant bracket"} # 273 hints
+- ignore: {name: "Redundant guard"} # 1 hint
- ignore: {name: "Redundant if"} # 6 hints
-- ignore: {name: "Redundant lambda"} # 19 hints
+- ignore: {name: "Redundant lambda"} # 16 hints
- ignore: {name: "Redundant multi-way if"} # 1 hint
- ignore: {name: "Redundant return"} # 9 hints
- ignore: {name: "Use $>"} # 5 hints
- ignore: {name: "Use ++"} # 4 hints
- ignore: {name: "Use :"} # 29 hints
- ignore: {name: "Use <$"} # 2 hints
-- ignore: {name: "Use <$>"} # 78 hints
+- ignore: {name: "Use <$>"} # 82 hints
- ignore: {name: "Use <&>"} # 16 hints
- ignore: {name: "Use <=<"} # 4 hints
- ignore: {name: "Use =<<"} # 7 hints
- ignore: {name: "Use >=>"} # 3 hints
- ignore: {name: "Use Down"} # 3 hints
- ignore: {name: "Use bimap"} # 7 hints
-- ignore: {name: "Use camelCase"} # 96 hints
+- ignore: {name: "Use camelCase"} # 97 hints
- ignore: {name: "Use const"} # 36 hints
-- ignore: {name: "Use fmap"} # 23 hints
- ignore: {name: "Use fold"} # 1 hint
- ignore: {name: "Use fst"} # 2 hints
- ignore: {name: "Use lambda-case"} # 58 hints
-- ignore: {name: "Use map once"} # 7 hints
-- ignore: {name: "Use map with tuple-section"} # 3 hints
- ignore: {name: "Use newtype instead of data"} # 31 hints
- ignore: {name: "Use null"} # 2 hints
- ignore: {name: "Use record patterns"} # 16 hints
-- ignore: {name: "Use replicateM_"} # 2 hints
-- ignore: {name: "Use typeRep"} # 2 hints
-- ignore: {name: "Use unless"} # 23 hints
- ignore: {name: "Use void"} # 23 hints
+- ignore: {name: "Functor law", within: [Test.Laws]}
+- ignore: {name: "Monoid law, left identity", within: [Test.Laws, UnitTests.Distribution.Utils.NubList]}
+- ignore: {name: "Monoid law, right identity", within: [Test.Laws, UnitTests.Distribution.Utils.NubList]}
+- ignore: {name: "Replace case with maybe", within: [Distribution.Client.InLibrary]}
+- ignore: {name: "Use fmap", within: [Distribution.Client.HttpUtils, Distribution.Simple.SrcDist]}
+
- group:
name: cabal-suggestions
enabled: true
@@ -57,8 +51,6 @@
- --ignore-glob=Cabal-syntax/src/Distribution/Fields/Lexer.hs
- --ignore-glob=Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs
- --ignore-glob=Cabal-tests/tests/custom-setup/IdrisSetup.hs
- # TODO: Remove --ignore-glob for ghc-supported-languages.hs when this module compiles
- - --ignore-glob=Cabal-tests/tests/misc/ghc-supported-languages.hs
- --ignore-glob=cabal-testsuite/PackageTests/BuildWays/q/app/Main.hs
- --ignore-glob=cabal-testsuite/PackageTests/CMain/10168/src/Lib.hs
- --ignore-glob=cabal-testsuite/PackageTests/CmmSources/src/Demo.hs
diff --git a/.typos-docs.toml b/.typos-docs.toml
index ac4a9ab73d3..60a65ccac71 100644
--- a/.typos-docs.toml
+++ b/.typos-docs.toml
@@ -2,6 +2,7 @@
extend-exclude = [
"changelog.d/pr-11501.md",
"changelog.d/pr-11602.md",
+ "changelog.d/pr-11621.md",
]
[default]
diff --git a/.typos-srcs.toml b/.typos-srcs.toml
index 5a0f09e63ec..bdaebdeada6 100644
--- a/.typos-srcs.toml
+++ b/.typos-srcs.toml
@@ -58,4 +58,3 @@ fo = "fo"
nto = "nto" # nto-qnx operating system
dows = "dows" # win-dows
bimap = "bimap"
-explitic = "explitic"
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index 408106fc711..6ce38f23080 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -1,5 +1,15 @@
# Contributing to Cabal
+## The fortnightly meeting
+
+We have a dev call every 2 weeks at https://meet.jit.si/FavourableEvilsAnnounceAppallingly. All contributors and potential contributors are welcome.
+
+
+## Issue triage [](https://www.codetriage.com/haskell/cabal)
+
+You can contribute by triaging issues, which may include reproducing bug reports or asking for vital information such as version numbers or reproduction instructions. If you would like to start triaging issues, one easy way to get started is to [subscribe to cabal on CodeTriage](https://www.codetriage.com/haskell/cabal).
+
+
## Building Cabal for hacking
If you use the `cabal` executable from the latest version of the
@@ -62,7 +72,7 @@ $ cabal build cabal-tests # etc...
There are two ways to run tests: in CI with GitHub actions and locally with
`./validate.sh`.
-### Using GitHub Actions.
+### Using GitHub Actions
If you are not in a hurry, the most convenient way to run tests on Cabal
is to make a branch on GitHub and then open a pull request; our
@@ -87,7 +97,7 @@ Some tips for using GitHub Actions effectively:
already failed), be nice to others and cancel the rest of the jobs,
so that other commits on the build queue can be processed.
-### How to debug a failing CI test.
+### How to debug a failing CI test
One of the annoying things about running tests on CI is when they
fail, there is often no easy way to further troubleshoot the broken
@@ -107,7 +117,7 @@ failures:
a specific operating system? If so, try reproducing the
problem on the specific configuration.
-4. Is the test failing on a GitHub Actions per-GHC build.
+4. Is the test failing on a GitHub Actions per-GHC build?
In this case, if you click on "Branch", you can get access to
the precise binaries that were built by GitHub Actions that are being
tested. If you have an Ubuntu system, you can download
@@ -116,7 +126,7 @@ failures:
If none of these let you reproduce, there might be some race condition
or continuous integration breakage; please file a bug.
-### Running tests locally.
+### Running tests locally
The [`./validate.sh`](./validate.sh) script runs all the test suites. It takes
various options to restrict the test suites it runs; use `--help` to list them.
@@ -267,19 +277,6 @@ you push a fix of a whitespace violation, please do so in a _separate commit_. F
support window, except Template Haskell, which would cause
bootstrapping problems in the GHC compilation process.
-* Our GHC support window is five years for the Cabal library and three
- years for cabal-install: that is, the Cabal library must be
- buildable out-of-the-box with the dependencies that shipped with GHC
- for at least five years. GitHub Actions checks this, so most
- developers submit a PR to see if their code works on all these
- versions of GHC. `cabal-install` must also be buildable on all
- supported GHCs, although it does not have to be buildable
- out-of-the-box. Instead, the `cabal-install/bootstrap.sh` script
- must be able to download and install all of the dependencies (this
- is also checked by CI). Also, self-upgrade to the latest version
- (i.e. `cabal install cabal-install`) must work with all versions of
- `cabal-install` released during the last three years.
-
* `Cabal` has its own Prelude, in `Distribution.Compat.Prelude`,
that provides a compatibility layer and exports some commonly
used additional functions. Use it in all new modules.
@@ -358,10 +355,6 @@ If your pull request consists of several commits, consider using `squash+merge
me` instead of `merge me`: the Mergify bot will squash all the commits into one
and concatenate the commit messages of the commits before merging.
-There is also a `merge+no rebase` label. Use this very sparingly, as not rebasing
-severely complicates Git history. It is intended for special circumstances, as when
-the PR branch cannot or should not be modified. If you have any questions about it,
-please ask us.
### Pull Requests & Issues
@@ -371,7 +364,7 @@ your proposed design, UX considerations, tradeoffs etc. and work them out with
other contributors. The PR itself is for implementation.
If a PR becomes out of sync with its issue, go back to the issue, update
-it, and continue the conversation there. Telltale signs of Issue/PR diverging
+it, and continue the conversation there. Telltale signs of an issue and PR diverging
are, for example: the PR growing bigger in scope; lengthy discussions
about things that are *not* implementation choices; a change in design.
@@ -379,17 +372,18 @@ If your PR is trivial you can omit this process (but explain in the PR why you
think it does not warrant an issue). Feel free to open a new issue (or new
issues) when appropriate.
+
### Pull request size
-Keep your pull requests small, write one pull request per feature, let
+Keep your pull requests small, write one pull request per feature, make
the content of the pull request match the title of the pull request.
-To get merged, your pull request needs to be reviewed by two other
+As mentioned above, your pull request needs to be reviewed by two other
contributors. Large pull requests are daunting to inspect, and the
back-and-forth between the author and reviewer can get frustrating and
difficult to follow.
-Split your pull requests in multiple ones if possible (e.g. a refactor
+Split your pull requests into multiple ones if possible (e.g. a refactor
and a feature implementation should go in two different pull requests).
This is *especially* important when we decide to backport a pull request
(be it fix or a feature).
@@ -397,6 +391,7 @@ This is *especially* important when we decide to backport a pull request
Thorough reviews mean fewer regressions, keeping your pull requests small
will improve Cabal codebase quality.
+
### Pull requests for `gh` users
Are you a [`gh`](https://cli.github.com/) (GitHub’s official command line tool)
@@ -410,16 +405,17 @@ This way you will not erase the
[PR template](.github/pull_request_template.md)
all contributors use.
+
## Changelog
-Anything that changes `cabal-install:exe:cabal` or changes exports from library
-modules or changes behaviour of functions exported from packages published to
+Anything that changes `cabal-install:exe:cabal`, changes exports from library
+modules, or changes behaviour of functions exported from packages published to
hackage is a user-visible change. Raising the
lower bound on `base` is most definitely a user-visible change because it
excludes versions of GHC from being able to build these packages.
When opening a pull request with a user-visible change, you should write one
-changelog entry (or more in case of multiple independent changes) — the
+changelog entry (or more in case of multiple independent changes). The
information will end up in our release notes.
Changelogs for the next release are stored in the `changelog.d` directory.
@@ -493,16 +489,18 @@ add an entry in `doc/file-format-changelog.rst`.
### Is my change `significant`?
-Use your best judgement and if unsure ask other maintainers. If your PR fixes
-a specific ticket, how busy was the discussion there? A new command or option
-most likely warrants a `significance: significant` tag, same with command
-line changes that disrupts the workflow of many users or an API change
-that requires substantial time to integrate in a program.
+Use your best judgement and if unsure ask the
+[maintainers](https://github.com/haskell/cabal-CABAL-MAINTAINERS.md).
+If your PR fixes a specific ticket, how busy was the discussion there?
+A new command or option most likely warrants a `significance: significant`
+tag, as do command line changes that disrupt the workflow of many users or
+API changes that require substantial updates for downstream users.
Put yourself in the shoes of the user: would you appreciate seeing this
change highlighted in the announcement post or release notes overview? If
so, add `significance: significant`.
+
## Communicating
There are a few main venues of communication:
@@ -516,20 +514,13 @@ There are a few main venues of communication:
* You can join the channel using a web client, even anonymously: https://web.libera.chat/#hackage
* Alternatively you can join it using [matrix](https://matrix.org/): https://matrix.to/#/#hackage:matrix.org
-## Releases
-
-Notes for how to make a release are at the
-wiki page ["Making a release"](https://github.com/haskell/cabal/wiki/Making-a-release).
-Currently, [@emilypi](https://github.com/emilypi), [@fgaz](https://github.com/fgaz) and [@Mikolaj](https://github.com/Mikolaj) have access to
-`haskell.org/cabal`, and [@Mikolaj](https://github.com/Mikolaj) is the point of contact for getting
-permissions.
## Preview Releases
We make preview releases available to facilitate testing of development builds.
Artifacts can be found on the [`cabal-head` release page](https://github.com/haskell/cabal/releases/tag/cabal-head).
-The Validate CI pipeline generates tarballs with a `cabal` executable. The executable gets uploaded to this release by the pipelines that run on `master`.
+The Build and release CI pipeline generates tarballs with a `cabal` executable. The executable gets uploaded to this release by the pipelines that run on `master`.
We currently make available builds for:
- Linux, dynamically linked (requiring `zlib`, `gmp`, `glibc`)
@@ -546,9 +537,6 @@ and then build by calling `cabal build cabal-install --enable-executable-static`
Auto-generated API documentation for the `master` branch of Cabal is automatically uploaded here: http://haskell.github.io/cabal-website/doc/html/Cabal/.
-## Issue triage [](https://www.codetriage.com/haskell/cabal)
-
-You can contribute by triaging issues which may include reproducing bug reports or asking for vital information, such as version numbers or reproduction instructions. If you would like to start triaging issues, one easy way to get started is to [subscribe to cabal on CodeTriage](https://www.codetriage.com/haskell/cabal).
## Hackage Revisions
@@ -556,27 +544,5 @@ We are reactive rather than proactive with revising bounds on our dependencies
for code already released on Hackage. If you would benefit from a version bump,
please, open a ticket and get familiar with
[our revision policy](https://github.com/haskell/cabal/issues/9531#issuecomment-1866930240).
-
-The burden of proof that the bump is harmless remains with you, but we have a CI
-setup to show that our main pipeline ("Validate") is fine with the bump. To use
-it, someone with enough permissions needs to go on the
-[Validate workflow page](https://github.com/haskell/cabal/actions/workflows/validate.yml)
-and dispatch it manually by clicking "Run workflow".
-
-Running workflow manually as discussed above allows you to supply two inputs:
-
-> allow-newer line
-> constraints line
-
-Going via an example, imagine that Cabal only allows `tar` or version less then
-or equal to 0.6, and you want to bump it to 0.6. Then, to show that Validate
-succeeds with `tar` 0.6, you should input
-
-- `tar` to the "allow-newer line"
-- `tar ==0.6` to the "constraints line"
-
-Hopefully, running the Validate pipeline with these inputs succeeds and you
-supply the link to the run in the ticket about bumping the bound and making a revision.
-
-If interested in technical details, refer to the parts of `validate.yml` that
-mention `hackage-revisions`.
+You should ensure that the bump is harmless remains with you, but we will test in our CI
+before making the revision.
diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs
index 9ffa8bf7b62..aacb86f8754 100644
--- a/Cabal-described/src/Distribution/Described.hs
+++ b/Cabal-described/src/Distribution/Described.hs
@@ -39,7 +39,7 @@ module Distribution.Described (
import Prelude
( Bool (..), Char, Either (..), Enum (..), Eq (..), Ord (..), Show (..), String
- , elem, fmap, foldr, id, map, maybe, otherwise, return, reverse, undefined
+ , elem, fmap, foldr, id, map, maybe, otherwise, return, reverse
, ($), (.), (<$>)
)
@@ -47,7 +47,7 @@ import Data.Functor.Identity (Identity (..))
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
-import Data.Typeable (Typeable, typeOf)
+import Data.Typeable (Typeable, typeRep)
import Data.Void (Void, vacuous)
import Test.QuickCheck (Arbitrary (..), Property, counterexample)
import Test.Tasty (TestTree, testGroup)
@@ -294,7 +294,7 @@ testDescribed _ = testGroup name
, testProperty "roundtrip" propRoundtrip
]
where
- name = show (typeOf (undefined :: a))
+ name = show (typeRep (Proxy :: Proxy a))
propParsec :: Ex a -> Property
propParsec (Example str) = counterexample (show res) $ case res of
diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs
index d17b1ac5851..d7ac41f9817 100644
--- a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs
+++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs
@@ -237,7 +237,7 @@ import Data.Map.Strict as Map
A Cabal package with @Hooks@ @build-type@ must define the Haskell module
@SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@.
-These *setup hooks* allow package authors to customise the configuration and
+These __setup hooks__ allow package authors to customise the configuration and
building of a package by providing certain hooks that get folded into the
general package configuration and building logic within @Cabal@.
@@ -359,8 +359,8 @@ following conditions apply:
[N] the rule is new, or
[S] the rule matches with an old rule, and either:
- [S1] a file dependency of the rule has been modified/created/deleted, or
- a (transitive) rule dependency of the rule is itself stale, or
+ [S1] a file dependency of the rule has been modified\/created\/deleted,
+ or a (transitive) rule dependency of the rule is itself stale, or
[S2] the rule is different from the old rule, e.g. the argument stored in
the rule command has changed, or the pointer to the action to run the
rule has changed. (This is determined using the @Eq Rule@ instance.)
diff --git a/Cabal-syntax/Cabal-syntax.cabal b/Cabal-syntax/Cabal-syntax.cabal
index bb5a13ffc75..d82255f0cd7 100644
--- a/Cabal-syntax/Cabal-syntax.cabal
+++ b/Cabal-syntax/Cabal-syntax.cabal
@@ -40,7 +40,7 @@ library
, parsec >= 3.1.13.0 && < 3.2
, pretty >= 1.1.1 && < 1.2
, text >= 2.0.2 && < 2.2
- , time >= 1.4.0.1 && < 1.16
+ , time >= 1.4.0.1 && < 1.17
-- 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)
@@ -52,9 +52,8 @@ library
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wno-unticked-promoted-constructors
-
- if impl(ghc >= 8.0)
- ghc-options: -Wcompat -Wnoncanonical-monad-instances
+ -Wcompat
+ -Wnoncanonical-monad-instances
if impl(ghc >= 8.0) && impl(ghc < 8.8)
ghc-options: -Wnoncanonical-monadfail-instances
diff --git a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs
index 3f0d44b0a0a..58799ee8aae 100644
--- a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs
+++ b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs
@@ -73,7 +73,7 @@ import Distribution.Compat.Parsing
--
-- > vowel = oneOf "aeiou"
oneOf :: CharParsing m => [Char] -> m Char
-oneOf xs = satisfy (\c -> c `elem` xs)
+oneOf xs = satisfy (`elem` xs)
{-# INLINE oneOf #-}
-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current
@@ -82,7 +82,7 @@ oneOf xs = satisfy (\c -> c `elem` xs)
--
-- > consonant = noneOf "aeiou"
noneOf :: CharParsing m => [Char] -> m Char
-noneOf xs = satisfy (\c -> c `notElem` xs)
+noneOf xs = satisfy (`notElem` xs)
{-# INLINE noneOf #-}
-- | Skips /zero/ or more white space characters. See also 'skipMany'.
diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs
index ea37af99a77..bf3493c2a2a 100644
--- a/Cabal-syntax/src/Distribution/Compat/Graph.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs
@@ -100,10 +100,11 @@ import Distribution.Utils.Structured (Structure (..), Structured (..))
import qualified Data.Array as Array
import qualified Data.Foldable as Foldable
import qualified Data.Graph as G
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
-import qualified Distribution.Compat.Prelude as Prelude
+import GHC.Stack (HasCallStack)
-- | A graph of nodes @a@. The nodes are expected to have instance
-- of class 'IsNode'.
@@ -114,7 +115,7 @@ data Graph a = Graph
, graphAdjoint :: G.Graph
, graphVertexToNode :: G.Vertex -> a
, graphKeyToVertex :: Key a -> Maybe G.Vertex
- , graphBroken :: [(a, [Key a])]
+ , graphBroken :: [(a, NonEmpty (Key a))]
}
-- NB: Not a Functor! (or Traversable), because you need
@@ -284,7 +285,7 @@ cycles g = [vs | CyclicSCC vs <- stronglyConnComp g]
-- | /O(1)/. Return a list of nodes paired with their broken
-- neighbors (i.e., neighbor keys which are not in the graph).
-- Requires amortized construction of graph.
-broken :: Graph a -> [(a, [Key a])]
+broken :: Graph a -> [(a, NonEmpty (Key a))]
broken g = graphBroken g
-- | Lookup the immediate neighbors from a key in the graph.
@@ -343,7 +344,7 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)
-- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@
-- instead. The values of the map are assumed to already
-- be in WHNF.
-fromMap :: IsNode a => Map (Key a) a -> Graph a
+fromMap :: forall a. (IsNode a, Eq (Key a)) => Map (Key a) a -> Graph a
fromMap m =
Graph
{ graphMap = m
@@ -352,17 +353,26 @@ fromMap m =
, graphAdjoint = G.transposeG g
, graphVertexToNode = vertex_to_node
, graphKeyToVertex = key_to_vertex
- , graphBroken = broke
+ , graphBroken =
+ map (\ns'' -> (fst (NE.head ns''), NE.map snd ns'')) $
+ NE.groupWith (nodeKey . fst) $
+ brokenEdges'
}
where
- try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)
+ brokenEdges' :: [(a, Key a)]
+ brokenEdges' = concat brokenEdges
+ brokenEdges :: [[(a, Key a)]]
(brokenEdges, edges) =
- unzip $
- [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
+ unzip
+ [ partitionEithers
+ [ case key_to_vertex n' of
+ Just v -> Right v
+ Nothing -> Left (n, n')
+ | n' <- nodeNeighbors n
+ ]
| n <- ns
]
- broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)
g = Array.listArray bounds edges
@@ -377,7 +387,7 @@ fromMap m =
bounds = (0, Map.size m - 1)
-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
-fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
+fromDistinctList :: HasCallStack => (IsNode a, Show (Key a)) => [a] -> Graph a
fromDistinctList =
fromMap
. Map.fromListWith (\_ -> duplicateError)
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
index d23ac5cbf51..cc6df0801e3 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
@@ -28,7 +28,6 @@ module Distribution.PackageDescription.Configuration
, mapCondTree
, mapTreeData
, mapTreeConds
- , mapTreeConstrs
, transformAllBuildInfos
, transformAllBuildDepends
, transformAllBuildDependsN
@@ -39,6 +38,7 @@ import Distribution.Compat.Prelude
import Prelude ()
-- lens
+import qualified Distribution.Compat.Lens as L
import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
@@ -64,6 +64,7 @@ import Distribution.Utils.Path (sameDirectory)
import Distribution.Version
import Data.Tree (Tree (Node))
+import Data.Tuple
------------------------------------------------------------------------------
@@ -192,7 +193,7 @@ resolveWithFlags
-- ^ Compiler information
-> [PackageVersionConstraint]
-- ^ Additional constraints
- -> [CondTree ConfVar [Dependency] PDTagged]
+ -> [CondTree ConfVar PDTagged]
-> ([Dependency] -> DepTestRslt)
-- ^ Dependency test function.
-> Either [MissingDependency] (TargetSet PDTagged, FlagAssignment)
@@ -203,10 +204,10 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
where
-- simplify trees by (partially) evaluating all conditions and converting
-- dependencies to dependency maps.
- simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]
+ simplifiedTrees :: [CondTree FlagName (PDTagged, DependencyMap)]
simplifiedTrees =
map
- ( mapTreeConstrs toDepMap -- convert to maps
+ ( mapTreeData (\x -> (x, toDepMap $ L.view L.targetBuildDepends x))
. addBuildableConditionPDTagged
. mapTreeConds (fst . simplifyWithSysParams os arch impl)
)
@@ -226,6 +227,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
flip map simplifiedTrees $
-- apply additional constraints to all dependencies
first (`constrainBy` constrs)
+ . swap
. simplifyCondTree (env flags)
deps = overallDependencies enabled targetSet
in case checkDeps (fromDepMap deps) of
@@ -262,15 +264,15 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
-- can determine that Buildable is always True, it returns the input unchanged.
-- If Buildable is always False, it returns the empty 'CondTree'.
addBuildableCondition
- :: (Eq v, Monoid a, Monoid c)
+ :: (Eq v, Monoid a)
=> (a -> BuildInfo)
- -> CondTree v c a
- -> CondTree v c a
+ -> CondTree v a
+ -> CondTree v a
addBuildableCondition getInfo t =
case extractCondition (buildable . getInfo) t of
Lit True -> t
- Lit False -> CondNode mempty mempty []
- c -> CondNode mempty mempty [condIfThen c t]
+ Lit False -> CondNode mempty []
+ c -> CondNode mempty [condIfThen c t]
-- | This is a special version of 'addBuildableCondition' for the 'PDTagged'
-- type.
@@ -282,16 +284,18 @@ addBuildableCondition getInfo t =
--
-- See for more details.
addBuildableConditionPDTagged
- :: (Eq v, Monoid c)
- => CondTree v c PDTagged
- -> CondTree v c PDTagged
+ :: Eq v
+ => CondTree v PDTagged
+ -> CondTree v PDTagged
addBuildableConditionPDTagged t =
case extractCondition (buildable . getInfo) t of
Lit True -> t
- Lit False -> deleteConstraints t
- c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]
+ Lit False -> mapTreeData deleteConstraints t
+ c -> CondNode mempty [condIfThenElse c t (mapTreeData deleteConstraints t)]
where
- deleteConstraints = mapTreeConstrs (const mempty)
+ deleteConstraints (Lib lib) = Lib (L.set L.targetBuildDepends mempty lib)
+ deleteConstraints (SubComp unqualName comp) = SubComp unqualName (L.set L.targetBuildDepends mempty comp)
+ deleteConstraints PDNull = PDNull
getInfo :: PDTagged -> BuildInfo
getInfo (Lib l) = libBuildInfo l
@@ -326,10 +330,10 @@ extractConditions f gpkg =
, extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
]
-freeVars :: CondTree ConfVar c a -> [FlagName]
+freeVars :: CondTree ConfVar a -> [FlagName]
freeVars t = [f | PackageFlag f <- freeVars' t]
where
- freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
+ freeVars' (CondNode _ ifs) = concatMap compfv ifs
compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
condfv c = case c of
Var v -> [v]
@@ -406,6 +410,12 @@ instance Semigroup PDTagged where
SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')
_ <> _ = cabalBug "Cannot combine incompatible tags"
+instance L.HasBuildInfo PDTagged where
+ buildInfo f x = case x of
+ Lib lib -> Lib <$> L.buildInfo f lib
+ SubComp name comp -> SubComp name <$> L.buildInfo f comp
+ PDNull -> PDNull <$ f mempty
+
-- | Create a package description with all configurations resolved.
--
-- This function takes a `GenericPackageDescription` and several environment
@@ -554,36 +564,47 @@ flattenPackageDescription
where
mlib = f <$> mlib0
where
- f lib = (libFillInDefaults . fst . ignoreConditions $ lib){libName = LMainLibName}
+ f :: CondTree ConfVar Library -> Library
+ f lib = (libFillInDefaults . ignoreConditions $ lib){libName = LMainLibName}
sub_libs = flattenLib <$> sub_libs0
flibs = flattenFLib <$> flibs0
exes = flattenExe <$> exes0
tests = flattenTst <$> tests0
bms = flattenBm <$> bms0
+
+ flattenLib :: (UnqualComponentName, CondTree ConfVar Library) -> Library
flattenLib (n, t) =
libFillInDefaults $
- (fst $ ignoreConditions t)
+ (ignoreConditions t)
{ libName = LSubLibName n
, libExposed = False
}
+
+ flattenFLib :: (UnqualComponentName, CondTree ConfVar ForeignLib) -> ForeignLib
flattenFLib (n, t) =
flibFillInDefaults $
- (fst $ ignoreConditions t)
+ (ignoreConditions t)
{ foreignLibName = n
}
+
+ flattenExe :: (UnqualComponentName, CondTree ConfVar Executable) -> Executable
flattenExe (n, t) =
exeFillInDefaults $
- (fst $ ignoreConditions t)
+ (ignoreConditions t)
{ exeName = n
}
+
+ flattenTst :: (UnqualComponentName, CondTree ConfVar TestSuite) -> TestSuite
flattenTst (n, t) =
testFillInDefaults $
- (fst $ ignoreConditions t)
+ (ignoreConditions t)
{ testName = n
}
+
+ flattenBm :: (UnqualComponentName, CondTree ConfVar Benchmark) -> Benchmark
flattenBm (n, t) =
benchFillInDefaults $
- (fst $ ignoreConditions t)
+ (ignoreConditions t)
{ benchmarkName = n
}
@@ -640,8 +661,6 @@ transformAllBuildDepends
transformAllBuildDepends f =
over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f
. over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
- -- cannot be point-free as normal because of higher rank
- . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)
-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
-- @build-depends@ fields.
@@ -652,5 +671,3 @@ transformAllBuildDependsN
transformAllBuildDependsN f =
over (L.traverseBuildInfos . L.targetBuildDepends) f
. over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f
- -- cannot be point-free as normal because of higher rank
- . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
index 24861389b8f..e9081256a2a 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
@@ -3,7 +3,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-- | 'GenericPackageDescription' Field descriptions
module Distribution.PackageDescription.FieldGrammar
@@ -101,8 +100,9 @@ packageDescriptionFieldGrammar
, c (Identity BuildType)
, c (Identity PackageName)
, c (Identity Version)
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (RelativePathNT from to) (RelativePath from to))
+ , c (List FSep (RelativePathNT Pkg File) (SymbolicPathX OnlyRelative Pkg File))
+ , c (List VCat (RelativePathNT DataDir File) (RelativePath DataDir File))
+ , c (List VCat (RelativePathNT Pkg File) (RelativePath Pkg File))
, c (List FSep TestedWith (CompilerFlavor, VersionRange))
, c CompatLicenseFile
, c CompatDataDir
@@ -180,9 +180,15 @@ libraryFieldGrammar
, c (List FSep Token String)
, c (List NoCommaFSep Token' String)
, c (List VCat (MQuoted ModuleName) ModuleName)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (SymbolicPathNT from to) (SymbolicPath from to))
+ , c (List VCat (RelativePathNT Pkg File) (RelativePath Pkg File))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include)))
+ , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File))
+ , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File))
+ , c (List FSep (RelativePathNT Include File) (RelativePath Include File))
+ , c (List VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File))
, c (List VCat Token String)
, c (MQuoted Language)
)
@@ -228,9 +234,15 @@ foreignLibFieldGrammar
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
, c (List FSep Token String)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (SymbolicPathNT from to) (SymbolicPath from to))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include)))
+ , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File))
+ , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File))
+ , c (List FSep (RelativePathNT Include File) (RelativePath Include File))
+ , c (List FSep (RelativePathNT Source File) (RelativePath Source File))
+ , c (List VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File))
, c (List NoCommaFSep Token' String)
, c (List VCat (MQuoted ModuleName) ModuleName)
, c (List VCat Token String)
@@ -266,13 +278,15 @@ executableFieldGrammar
, c (List FSep (MQuoted Extension) Extension)
, c (List FSep (MQuoted Language) Language)
, c (List FSep Token String)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (SymbolicPathNT from to)
- , forall from to. c (RelativePathNT from to)
+ , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include)))
+ , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File))
+ , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File))
+ , c (List FSep (RelativePathNT Include File) (RelativePath Include File))
+ , c (List VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File))
+ , c (RelativePathNT Source File)
, c (List NoCommaFSep Token' String)
, c (List VCat (MQuoted ModuleName) ModuleName)
, c (List VCat Token String)
@@ -344,10 +358,15 @@ testSuiteFieldGrammar
, c (List FSep Token String)
, c (List NoCommaFSep Token' String)
, c (List VCat (MQuoted ModuleName) ModuleName)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (RelativePathNT from to)
+ , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include)))
+ , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File))
+ , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File))
+ , c (List FSep (RelativePathNT Include File) (RelativePath Include File))
+ , c (List VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File))
+ , c (RelativePathNT Source File)
, c (List VCat Token String)
, c (MQuoted Language)
)
@@ -488,10 +507,15 @@ benchmarkFieldGrammar
, c (List FSep Token String)
, c (List NoCommaFSep Token' String)
, c (List VCat (MQuoted ModuleName) ModuleName)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (RelativePathNT from to)
+ , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include)))
+ , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File))
+ , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File))
+ , c (List FSep (RelativePathNT Include File) (RelativePath Include File))
+ , c (List VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File))
+ , c (RelativePathNT Source File)
, c (List VCat Token String)
, c (MQuoted Language)
)
@@ -590,9 +614,14 @@ buildInfoFieldGrammar
, c (List FSep Token String)
, c (List NoCommaFSep Token' String)
, c (List VCat (MQuoted ModuleName) ModuleName)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
- , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to))
- , forall from to. c (List VCat (SymbolicPathNT from to) (SymbolicPath from to))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include)))
+ , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File))
+ , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File))
+ , c (List FSep (RelativePathNT Include File) (RelativePath Include File))
+ , c (List VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File))
, c (List VCat Token String)
, c (MQuoted Language)
)
@@ -689,7 +718,7 @@ buildInfoFieldGrammar =
hsSourceDirsGrammar
:: ( FieldGrammar c g
, Applicative (g BuildInfo)
- , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to))
+ , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source)))
)
=> g BuildInfo [SymbolicPath Pkg (Dir Source)]
hsSourceDirsGrammar =
@@ -758,8 +787,8 @@ profSharedOptionsFieldGrammar =
lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v
lookupLens k f p@(PerCompilerFlavor ghc ghcjs)
- | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc
- | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs
+ | k == GHC = (`PerCompilerFlavor` ghcjs) <$> f ghc
+ | k == GHCJS = (ghc `PerCompilerFlavor`) <$> f ghcjs
| otherwise = p <$ f mempty
-------------------------------------------------------------------------------
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs
index e5f0e4f406b..f323764621d 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs
@@ -133,7 +133,7 @@ data SectionS = SectionS
}
stateGpd :: Lens' SectionS GenericPackageDescription
-stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd
+stateGpd f (SectionS gpd cs) = (`SectionS` cs) <$> f gpd
{-# INLINE stateGpd #-}
stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo)
@@ -263,7 +263,7 @@ goSections specVer = traverse_ process
-> Map String CondTreeBuildInfo
-- \^ common stanzas
-> [Field Position]
- -> ParseResult src (CondTree ConfVar [Dependency] a)
+ -> ParseResult src (CondTree ConfVar a)
parseCondTree' = parseCondTreeWithCommonStanzas specVer
parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser src ()
@@ -478,11 +478,9 @@ parseCondTree
-- ^ common stanzas
-> (BuildInfo -> a)
-- ^ constructor from buildInfo
- -> (a -> [Dependency])
- -- ^ condition extractor
-> [Field Position]
- -> ParseResult src (CondTree ConfVar [Dependency] a)
-parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
+ -> ParseResult src (CondTree ConfVar a)
+parseCondTree v hasElif grammar commonStanzas fromBuildInfo = go
where
go fields0 = do
(fields, endo) <-
@@ -493,9 +491,9 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
let (fs, ss) = partitionFields fields
x <- parseFieldGrammar v fs grammar
branches <- concat <$> traverse parseIfs ss
- return $ endo $ CondNode x (cond x) branches
+ return $ endo $ CondNode x branches
- parseIfs :: [Section Position] -> ParseResult src [CondBranch ConfVar [Dependency] a]
+ parseIfs :: [Section Position] -> ParseResult src [CondBranch ConfVar a]
parseIfs [] = return []
parseIfs (MkSection (Name pos name) test fields : sections) | name == "if" = do
test' <- parseConditionConfVar (startOfSection (incPos 2 pos) test) test
@@ -508,7 +506,7 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
parseElseIfs
:: [Section Position]
- -> ParseResult src (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
+ -> ParseResult src (Maybe (CondTree ConfVar a), [CondBranch ConfVar a])
parseElseIfs [] = return (Nothing, [])
parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do
unless (null args) $
@@ -525,7 +523,7 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
(elseFields, sections') <- parseElseIfs sections
-- we parse an empty 'Fields', to get empty value for a node
a <- parseFieldGrammar v mempty grammar
- return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
+ return (Just $ CondNode a [CondBranch test' fields' elseFields], sections')
parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do
parseWarning pos PWTInvalidSubsection "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
(,) Nothing <$> parseIfs sections
@@ -593,7 +591,7 @@ with new AST, this all need to be rewritten.
-- The approach is simple, and have good properties:
--
-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
-type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
+type CondTreeBuildInfo = CondTree ConfVar BuildInfo
-- | Create @a@ from 'BuildInfo'.
-- This class is used to implement common stanza parsing.
@@ -635,10 +633,10 @@ parseCondTreeWithCommonStanzas
-> Map String CondTreeBuildInfo
-- ^ common stanzas
-> [Field Position]
- -> ParseResult src (CondTree ConfVar [Dependency] a)
+ -> ParseResult src (CondTree ConfVar a)
parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do
(fields', endo) <- processImports v fromBuildInfo commonStanzas fields
- x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'
+ x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo fields'
return (endo x)
where
hasElif = specHasElif v
@@ -652,7 +650,7 @@ processImports
-> Map String CondTreeBuildInfo
-- ^ common stanzas
-> [Field Position]
- -> ParseResult src ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)
+ -> ParseResult src ([Field Position], CondTree ConfVar a -> CondTree ConfVar a)
processImports v fromBuildInfo commonStanzas = go []
where
hasCommonStanzas = specHasCommonStanzas v
@@ -695,11 +693,11 @@ warnImport _ f = pure (Just f)
mergeCommonStanza
:: L.HasBuildInfo a
=> (BuildInfo -> a)
- -> CondTree ConfVar [Dependency] BuildInfo
- -> CondTree ConfVar [Dependency] a
- -> CondTree ConfVar [Dependency] a
-mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
- CondNode x' (x' ^. L.targetBuildDepends) cs'
+ -> CondTree ConfVar BuildInfo
+ -> CondTree ConfVar a
+ -> CondTree ConfVar a
+mergeCommonStanza fromBuildInfo (CondNode bi bis) (CondNode x cs) =
+ CondNode x' cs'
where
-- new value is old value with buildInfo field _prepended_.
x' = x & L.buildInfo %~ (bi <>)
@@ -712,7 +710,7 @@ mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
-------------------------------------------------------------------------------
-- Check that a property holds on all branches of a condition tree
-onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool
+onAllBranches :: forall v a. Monoid a => (a -> Bool) -> CondTree v a -> Bool
onAllBranches p = go mempty
where
-- If the current level of the tree satisfies the property, then we are
@@ -720,13 +718,13 @@ onAllBranches p = go mempty
-- must satisfy it. Each node may have multiple immediate children; we only
-- one need one to satisfy the property because the configure step uses
-- 'mappend' to join together the results of flag resolution.
- go :: a -> CondTree v c a -> Bool
+ go :: a -> CondTree v a -> Bool
go acc ct =
let acc' = acc `mappend` condTreeData ct
in p acc' || any (goBranch acc') (condTreeComponents ct)
-- Both the 'true' and the 'false' block must satisfy the property.
- goBranch :: a -> CondBranch v c a -> Bool
+ goBranch :: a -> CondBranch v a -> Bool
goBranch _ (CondBranch _ _ Nothing) = False
goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
@@ -750,7 +748,7 @@ checkForUndefinedFlags gpd = do
"These flags are used without having been defined: "
++ intercalate ", " [unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags]
where
- f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a)
+ f :: CondTree ConfVar a -> Const (Set.Set FlagName) (CondTree ConfVar a)
f ct = Const (Set.fromList (freeVars ct))
-- | Since @cabal-version: 1.24@ one can specify @custom-setup@.
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs
index 47622b0c43c..dbd872d2823 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs
@@ -121,11 +121,11 @@ ppFlag v flag@(MkPackageFlag name _ _ _) =
PrettySection () "flag" [ppFlagName name] $
prettyFieldGrammar v (flagFieldGrammar name) flag
-ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()]
+ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar s -> [PrettyField ()]
ppCondTree2 v grammar = go
where
-- TODO: recognise elif opportunities
- go (CondNode it _ ifs) =
+ go (CondNode it ifs) =
prettyFieldGrammar v grammar it
++ concatMap ppIf ifs
@@ -140,42 +140,42 @@ ppCondTree2 v grammar = go
, PrettySection () "else" [] (go elseTree)
]
-ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()]
+ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar Library) -> [PrettyField ()]
ppCondLibrary _ Nothing = mempty
ppCondLibrary v (Just condTree) =
pure $
PrettySection () "library" [] $
ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree
-ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()]
+ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Library)] -> [PrettyField ()]
ppCondSubLibraries v libs =
[ PrettySection () "library" [pretty n] $
ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree
| (n, condTree) <- libs
]
-ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()]
+ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar ForeignLib)] -> [PrettyField ()]
ppCondForeignLibs v flibs =
[ PrettySection () "foreign-library" [pretty n] $
ppCondTree2 v (foreignLibFieldGrammar n) condTree
| (n, condTree) <- flibs
]
-ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()]
+ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Executable)] -> [PrettyField ()]
ppCondExecutables v exes =
[ PrettySection () "executable" [pretty n] $
ppCondTree2 v (executableFieldGrammar n) condTree
| (n, condTree) <- exes
]
-ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()]
+ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar TestSuite)] -> [PrettyField ()]
ppCondTestSuites v suites =
[ PrettySection () "test-suite" [pretty n] $
ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)
| (n, condTree) <- suites
]
-ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()]
+ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Benchmark)] -> [PrettyField ()]
ppCondBenchmarks v suites =
[ PrettySection () "benchmark" [pretty n] $
ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)
@@ -241,14 +241,14 @@ pdToGpd pd =
where
-- We set CondTree's [Dependency] to an empty list, as it
-- is not pretty printed anyway.
- mkCondTree x = CondNode x [] []
- mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] [])
+ mkCondTree x = CondNode x []
+ mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [])
mkCondTree'
:: (a -> UnqualComponentName)
-> a
- -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
- mkCondTree' f x = (f x, CondNode x [] [])
+ -> (UnqualComponentName, CondTree ConfVar a)
+ mkCondTree' f x = (f x, CondNode x [])
-------------------------------------------------------------------------------
-- Internal libs
diff --git a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs
index c42d33ad7b9..1e979a5671c 100644
--- a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs
+++ b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs
@@ -45,7 +45,7 @@ instance Monad m => Parsec.Stream FieldLineStream m Char where
uncons (FLSCons bs s) = return $ case BS.uncons bs of
-- as lines are glued with '\n', we return '\n' here!
Nothing -> Just ('\n', s)
- Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s)
+ Just (c, bs') -> Just (unconsChar c bs' (`FLSCons` s) s)
unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar c0 bs0 f next = go (utf8DecodeStart c0) bs0
diff --git a/Cabal-syntax/src/Distribution/Types/CondTree.hs b/Cabal-syntax/src/Distribution/Types/CondTree.hs
index c74ffdf6395..f18444d672c 100644
--- a/Cabal-syntax/src/Distribution/Types/CondTree.hs
+++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs
@@ -10,13 +10,12 @@ module Distribution.Types.CondTree
, condIfThenElse
, foldCondTree
, mapCondTree
- , mapTreeConstrs
, mapTreeConds
, mapTreeData
+ , traverseCondTreeA
, traverseCondTreeV
+ , traverseCondBranchA
, traverseCondBranchV
- , traverseCondTreeC
- , traverseCondBranchC
, extractCondition
, simplifyCondTree
, simplifyCondBranch
@@ -54,109 +53,99 @@ import qualified Distribution.Compat.Lens as L
-- derived off of 'targetBuildInfo' (perhaps a good refactoring
-- would be to convert this into an opaque type, with a smart
-- constructor that pre-computes the dependencies.)
-data CondTree v c a = CondNode
+data CondTree v a = CondNode
{ condTreeData :: a
- , condTreeConstraints :: c
- , condTreeComponents :: [CondBranch v c a]
+ , condTreeComponents :: [CondBranch v a]
}
deriving (Show, Eq, Data, Generic, Functor, Foldable, Traversable)
-instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)
-instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a)
-instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf
+instance (Binary v, Binary a) => Binary (CondTree v a)
+instance (Structured v, Structured a) => Structured (CondTree v a)
+instance (NFData v, NFData a) => NFData (CondTree v a) where rnf = genericRnf
-instance (Semigroup a, Semigroup c) => Semigroup (CondTree v c a) where
- (CondNode a c bs) <> (CondNode a' c' bs') = CondNode (a <> a') (c <> c') (bs <> bs')
+instance Semigroup a => Semigroup (CondTree v a) where
+ (CondNode a bs) <> (CondNode a' bs') = CondNode (a <> a') (bs <> bs')
-instance (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (CondTree v c a) where
+instance (Semigroup a, Monoid a) => Monoid (CondTree v a) where
mappend = (<>)
- mempty = CondNode mempty mempty mempty
+ mempty = CondNode mempty mempty
-- | A 'CondBranch' represents a conditional branch, e.g., @if
-- flag(foo)@ on some syntax @a@. It also has an optional false
-- branch.
-data CondBranch v c a = CondBranch
+data CondBranch v a = CondBranch
{ condBranchCondition :: Condition v
- , condBranchIfTrue :: CondTree v c a
- , condBranchIfFalse :: Maybe (CondTree v c a)
+ , condBranchIfTrue :: CondTree v a
+ , condBranchIfFalse :: Maybe (CondTree v a)
}
- deriving (Show, Eq, Data, Generic, Functor, Traversable)
+ deriving (Show, Eq, Data, Generic, Functor, Traversable, Foldable)
--- This instance is written by hand because GHC 8.0.1/8.0.2 infinite
--- loops when trying to derive it with optimizations. See
--- https://gitlab.haskell.org/ghc/ghc/-/issues/13056
-instance Foldable (CondBranch v c) where
- foldMap f (CondBranch _ c Nothing) = foldMap f c
- foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a
+instance (Binary v, Binary a) => Binary (CondBranch v a)
+instance (Structured v, Structured a) => Structured (CondBranch v a)
+instance (NFData v, NFData a) => NFData (CondBranch v a) where rnf = genericRnf
-instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)
-instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a)
-instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf
-
-condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a
+condIfThen :: Condition v -> CondTree v a -> CondBranch v a
condIfThen c t = CondBranch c t Nothing
-condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a
+condIfThenElse :: Condition v -> CondTree v a -> CondTree v a -> CondBranch v a
condIfThenElse c t e = CondBranch c t (Just e)
mapCondTree
:: (a -> b)
- -> (c -> d)
-> (Condition v -> Condition w)
- -> CondTree v c a
- -> CondTree w d b
-mapCondTree fa fc fcnd (CondNode a c ifs) =
- CondNode (fa a) (fc c) (map g ifs)
+ -> CondTree v a
+ -> CondTree w b
+mapCondTree fa fcnd (CondNode a ifs) =
+ CondNode (fa a) (map g ifs)
where
g (CondBranch cnd t me) =
CondBranch
(fcnd cnd)
- (mapCondTree fa fc fcnd t)
- (fmap (mapCondTree fa fc fcnd) me)
+ (mapCondTree fa fcnd t)
+ (fmap (mapCondTree fa 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 a -> CondTree w a
+mapTreeConds f = mapCondTree id f
-mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
-mapTreeConds f = mapCondTree id id f
+mapTreeData :: (a -> b) -> CondTree v a -> CondTree v b
+mapTreeData f = mapCondTree f id
-mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
-mapTreeData f = mapCondTree f id id
+-- | @@Traversal@@ for the data
+traverseCondTreeA :: L.Traversal (CondTree v a) (CondTree v b) a b
+traverseCondTreeA f (CondNode a ifs) =
+ CondNode
+ <$> f a
+ <*> traverse (traverseCondBranchA f) ifs
-- | @@Traversal@@ for the variables
-traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w
-traverseCondTreeV f (CondNode a c ifs) =
- CondNode a c <$> traverse (traverseCondBranchV f) ifs
+traverseCondTreeV :: L.Traversal (CondTree v a) (CondTree w a) v w
+traverseCondTreeV f (CondNode a ifs) =
+ CondNode a <$> traverse (traverseCondBranchV f) ifs
+
+-- | @@Traversal@@ for the data
+traverseCondBranchA :: L.Traversal (CondBranch v a) (CondBranch v b) a b
+traverseCondBranchA f (CondBranch cnd t me) =
+ pure (CondBranch cnd)
+ <*> traverseCondTreeA f t
+ <*> traverse (traverseCondTreeA f) me
-- | @@Traversal@@ for the variables
-traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w
+traverseCondBranchV :: L.Traversal (CondBranch v a) (CondBranch w a) v w
traverseCondBranchV f (CondBranch cnd t me) =
CondBranch
<$> traverse f cnd
<*> traverseCondTreeV f t
<*> traverse (traverseCondTreeV f) me
--- | @@Traversal@@ for the aggregated constraints
-traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d
-traverseCondTreeC f (CondNode a c ifs) =
- CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs
-
--- | @@Traversal@@ for the aggregated constraints
-traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d
-traverseCondBranchC f (CondBranch cnd t me) =
- CondBranch cnd
- <$> traverseCondTreeC f t
- <*> traverse (traverseCondTreeC f) me
-
-- | Extract the condition matched by the given predicate from a cond tree.
--
-- We use this mainly for extracting buildable conditions (see the Note in
-- Distribution.PackageDescription.Configuration), but the function is in fact
-- more general.
-extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
+extractCondition :: Eq v => (a -> Bool) -> CondTree v a -> Condition v
extractCondition p = go
where
- go (CondNode x _ cs)
+ go (CondNode x cs)
| not (p x) = Lit False
| otherwise = goList cs
@@ -171,20 +160,20 @@ extractCondition p = go
-- | Flattens a CondTree using a partial flag assignment. When a condition
-- cannot be evaluated, both branches are ignored.
simplifyCondTree
- :: (Semigroup a, Semigroup d)
+ :: Semigroup a
=> (v -> Either v Bool)
- -> CondTree v d a
- -> (d, a)
-simplifyCondTree env (CondNode a d ifs) =
- foldl (<>) (d, a) $ mapMaybe (simplifyCondBranch env) ifs
+ -> CondTree v a
+ -> a
+simplifyCondTree env (CondNode a ifs) =
+ foldl (<>) a $ mapMaybe (simplifyCondBranch env) ifs
-- | Realizes a 'CondBranch' using partial flag assignment. When a condition
-- cannot be evaluated, returns 'Nothing'.
simplifyCondBranch
- :: (Semigroup a, Semigroup d)
+ :: Semigroup a
=> (v -> Either v Bool)
- -> CondBranch v d a
- -> Maybe (d, a)
+ -> CondBranch v a
+ -> Maybe a
simplifyCondBranch env (CondBranch cnd t me) =
case simplifyCondition cnd env of
(Lit True, _) -> Just $ simplifyCondTree env t
@@ -194,8 +183,8 @@ simplifyCondBranch env (CondBranch cnd t me) =
-- | Flatten a CondTree. This will resolve the CondTree by taking all
-- possible paths into account. Note that since branches represent exclusive
-- choices this may not result in a \"sane\" result.
-ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c)
-ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs
+ignoreConditions :: Semigroup a => CondTree v a -> a
+ignoreConditions (CondNode a ifs) = foldl (<>) a $ concatMap f ifs
where
f (CondBranch _ t me) =
ignoreConditions t
@@ -204,10 +193,10 @@ ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs
-- | Flatten a CondTree. This will traverse the CondTree by taking all
-- possible paths into account, but merging inclusive when two paths
-- may co-exist, and exclusively when the paths are an if/else
-foldCondTree :: forall b c a v. b -> ((c, a) -> b) -> (b -> b -> b) -> (b -> b -> b) -> CondTree v c a -> b
+foldCondTree :: forall b a v. b -> (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> CondTree v a -> b
foldCondTree e u mergeInclusive mergeExclusive = goTree
where
- goTree :: CondTree v c a -> b
- goTree (CondNode a c ifs) = u (c, a) `mergeInclusive` foldl goBranch e ifs
- goBranch :: b -> CondBranch v c a -> b
+ goTree :: CondTree v a -> b
+ goTree (CondNode a ifs) = u a `mergeInclusive` foldl goBranch e ifs
+ goBranch :: b -> CondBranch v a -> b
goBranch acc (CondBranch _ t mt) = mergeInclusive acc (maybe (goTree t) (mergeExclusive (goTree t) . goTree) mt)
diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs
index 97f4ed8cccb..67c39879614 100644
--- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs
+++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs
@@ -44,30 +44,30 @@ data GenericPackageDescription = GenericPackageDescription
-- Perfectly, PackageIndex should have sum type, so we don't need to
-- have dummy GPDs.
, genPackageFlags :: [PackageFlag]
- , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
+ , condLibrary :: Maybe (CondTree ConfVar Library)
, condSubLibraries
:: [ ( UnqualComponentName
- , CondTree ConfVar [Dependency] Library
+ , CondTree ConfVar Library
)
]
, condForeignLibs
:: [ ( UnqualComponentName
- , CondTree ConfVar [Dependency] ForeignLib
+ , CondTree ConfVar ForeignLib
)
]
, condExecutables
:: [ ( UnqualComponentName
- , CondTree ConfVar [Dependency] Executable
+ , CondTree ConfVar Executable
)
]
, condTestSuites
:: [ ( UnqualComponentName
- , CondTree ConfVar [Dependency] TestSuite
+ , CondTree ConfVar TestSuite
)
]
, condBenchmarks
:: [ ( UnqualComponentName
- , CondTree ConfVar [Dependency] Benchmark
+ , CondTree ConfVar Benchmark
)
]
}
@@ -92,29 +92,9 @@ instance L.HasBuildInfos GenericPackageDescription where
<$> L.traverseBuildInfos f p
<*> pure v
<*> pure a1
- <*> (traverse . traverseCondTreeBuildInfo) f x1
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6
-
--- We use this traversal to keep [Dependency] field in CondTree up to date.
-traverseCondTreeBuildInfo
- :: forall f comp v
- . (Applicative f, L.HasBuildInfo comp)
- => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo
-traverseCondTreeBuildInfo g = node
- where
- mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp
- mkCondNode comp = CondNode comp (view L.targetBuildDepends comp)
-
- node (CondNode comp _ branches) =
- mkCondNode
- <$> L.buildInfo g comp
- <*> traverse branch branches
-
- branch (CondBranch v x y) =
- CondBranch v
- <$> node x
- <*> traverse node y
+ <*> (traverse . traverse . L.buildInfo) f x1
+ <*> (traverse . L._2 . traverse . L.buildInfo) f x2
+ <*> (traverse . L._2 . traverse . L.buildInfo) f x3
+ <*> (traverse . L._2 . traverse . L.buildInfo) f x4
+ <*> (traverse . L._2 . traverse . L.buildInfo) f x5
+ <*> (traverse . L._2 . traverse . L.buildInfo) f x6
diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs
index 213c97128f9..951c7cf826b 100644
--- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs
@@ -22,7 +22,6 @@ import Distribution.System (Arch, OS)
import Distribution.Types.Benchmark (Benchmark)
import Distribution.Types.CondTree (CondTree)
import Distribution.Types.ConfVar (ConfVar (..))
-import Distribution.Types.Dependency (Dependency)
import Distribution.Types.Executable (Executable)
import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag))
import Distribution.Types.ForeignLib (ForeignLib)
@@ -49,41 +48,40 @@ genPackageFlags :: Lens' GenericPackageDescription [PackageFlag]
genPackageFlags f s = fmap (\x -> s{T.genPackageFlags = x}) (f (T.genPackageFlags s))
{-# INLINE genPackageFlags #-}
-condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library))
+condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar Library))
condLibrary f s = fmap (\x -> s{T.condLibrary = x}) (f (T.condLibrary s))
{-# INLINE condLibrary #-}
-condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Library))]
+condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar Library))]
condSubLibraries f s = fmap (\x -> s{T.condSubLibraries = x}) (f (T.condSubLibraries s))
{-# INLINE condSubLibraries #-}
-condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] ForeignLib))]
+condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar ForeignLib))]
condForeignLibs f s = fmap (\x -> s{T.condForeignLibs = x}) (f (T.condForeignLibs s))
{-# INLINE condForeignLibs #-}
-condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Executable))]
+condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar Executable))]
condExecutables f s = fmap (\x -> s{T.condExecutables = x}) (f (T.condExecutables s))
{-# INLINE condExecutables #-}
-condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] TestSuite))]
+condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar TestSuite))]
condTestSuites f s = fmap (\x -> s{T.condTestSuites = x}) (f (T.condTestSuites s))
{-# INLINE condTestSuites #-}
-condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Benchmark))]
+condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar Benchmark))]
condBenchmarks f s = fmap (\x -> s{T.condBenchmarks = x}) (f (T.condBenchmarks s))
{-# INLINE condBenchmarks #-}
allCondTrees
:: Applicative f
=> ( forall a
- . CondTree ConfVar [Dependency] a
- -> f (CondTree ConfVar [Dependency] a)
+ . CondTree ConfVar a
+ -> f (CondTree ConfVar a)
)
-> GenericPackageDescription
-> f GenericPackageDescription
allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
- GenericPackageDescription
- <$> pure p
+ pure (GenericPackageDescription p)
<*> pure v
<*> pure a1
<*> traverse f x1
diff --git a/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs b/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs
index f5c08ac2747..4db2d46a947 100644
--- a/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs
+++ b/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs
@@ -43,7 +43,7 @@ instance Parsec LegacyExeDependency where
verRange <- parsecMaybeQuoted parsec <|> pure anyVersion
pure $ LegacyExeDependency name verRange
where
- nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-')
+ nameP = intercalate "-" . toList <$> P.sepByNonEmpty component (P.char '-')
component = do
cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
if all isDigit cs then fail "invalid component" else return cs
diff --git a/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs b/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs
index d0317205f6a..b8a5d3d2900 100644
--- a/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs
+++ b/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs
@@ -49,7 +49,7 @@ interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName
interpModuleRenaming DefaultRenaming = Just
interpModuleRenaming (ModuleRenaming rns) =
let m = Map.fromList rns
- in \k -> Map.lookup k m
+ in (`Map.lookup` m)
interpModuleRenaming (HidingRenaming hs) =
let s = Set.fromList hs
in \k -> if k `Set.member` s then Nothing else Just k
diff --git a/Cabal-syntax/src/Distribution/Types/Version.hs b/Cabal-syntax/src/Distribution/Types/Version.hs
index c821062ee3d..8b5ea95fcea 100644
--- a/Cabal-syntax/src/Distribution/Types/Version.hs
+++ b/Cabal-syntax/src/Distribution/Types/Version.hs
@@ -99,7 +99,7 @@ instance Pretty Version where
)
instance Parsec Version where
- parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags
+ parsec = (mkVersion . toList <$> P.sepByNonEmpty versionDigitParser (P.char '.')) <* tags
where
tags = do
ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)
diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs
index a62b82fc04b..cd3082fc7ce 100644
--- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs
+++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs
@@ -513,7 +513,7 @@ versionRangeParser digitParser csv = expr
-- a plain version without tags or wildcards
verPlain :: CabalParsing m => m Version
- verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.')
+ verPlain = mkVersion . toList <$> P.sepByNonEmpty digitParser (P.char '.')
-- either wildcard or normal version
verOrWild :: CabalParsing m => m (Bool, Version)
diff --git a/Cabal-syntax/src/Distribution/Utils/Generic.hs b/Cabal-syntax/src/Distribution/Utils/Generic.hs
index e4aaf4b3d9c..11c00933ded 100644
--- a/Cabal-syntax/src/Distribution/Utils/Generic.hs
+++ b/Cabal-syntax/src/Distribution/Utils/Generic.hs
@@ -544,7 +544,7 @@ unfoldrM f = go
m <- f b
case m of
Nothing -> return []
- Just (a, b') -> liftM (a :) (go b')
+ Just (a, b') -> (a :) <$> (go b')
-- | The opposite of 'snoc', which is the reverse of 'cons'
--
diff --git a/Cabal-syntax/src/Language/Haskell/Extension.hs b/Cabal-syntax/src/Language/Haskell/Extension.hs
index 26cd45edac8..dbc9cc2ffd7 100644
--- a/Cabal-syntax/src/Language/Haskell/Extension.hs
+++ b/Cabal-syntax/src/Language/Haskell/Extension.hs
@@ -556,6 +556,12 @@ data KnownExtension
| -- | Allow use of or-pattern syntax, condensing multiple patterns
-- into a single one.
OrPatterns
+ | -- | Along with 'ImplicitStagePersistence', this gives fine-grained control
+ -- over which modules are needed at each stage of execution.
+ ExplicitLevelImports
+ | -- | Allow identifiers to be used at different levels than where they’re
+ -- defined, using path-based persistence.
+ ImplicitStagePersistence
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Data)
instance Binary KnownExtension
diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal
index f9fe954f76f..50ee8893b3f 100644
--- a/Cabal-tests/Cabal-tests.cabal
+++ b/Cabal-tests/Cabal-tests.cabal
@@ -200,3 +200,13 @@ test-suite no-thunks-test
if impl(ghc >=8.6)
build-depends:
, nothunks >=0.1.1.0 && <0.3
+
+executable ghc-supported-extensions
+ hs-source-dirs: exes
+ main-is: GhcSupportedExtensions.hs
+ build-depends:
+ , base
+ , Cabal
+
+ ghc-options: -Wall
+ default-language: Haskell2010
diff --git a/Cabal-tests/exes/GhcSupportedExtensions.hs b/Cabal-tests/exes/GhcSupportedExtensions.hs
new file mode 100644
index 00000000000..d7d203fcce1
--- /dev/null
+++ b/Cabal-tests/exes/GhcSupportedExtensions.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- | A test program to check that ghc has got all of its extensions registered
+-- with `KnownExtension` of Cabal-syntax.
+module Main where
+
+import Distribution.Compat.Prelude
+import Distribution.Pretty (prettyShow)
+import Distribution.Simple.Utils (rawSystemStdout)
+import Distribution.Text (display, simpleParse)
+import Distribution.Verbosity (Verbosity (..), defaultVerbosityHandles, normal)
+import Language.Haskell.Extension (Extension (..), knownLanguages)
+
+import Data.List ((\\))
+import System.Environment (getArgs, getProgName)
+
+-- | Language editions as Extensions.
+--
+-- >>> langsAsExts
+-- [UnknownExtension "Haskell98",UnknownExtension "Haskell2010",UnknownExtension "GHC2021",UnknownExtension "GHC2024"]
+--
+-- Both of the following calls to @ghc@ return the same set of results but we
+-- want to separate `Language` editions from other extensions (both enabled and
+-- disabled) so we need a list of `knownLanguages` as unknown extensions that we
+-- can then use to filter out those languages.
+--
+-- @
+
+-- $ ghc --supported-languages
+-- Haskell98
+-- Haskell2010
+-- GHC2021
+-- GHC2024
+-- Unsafe
+-- Trustworthy
+-- Safe
+-- CPP
+-- NoCPP
+-- ...
+
+-- $ ghc --supported-extensions
+-- Haskell98
+-- Haskell2010
+-- GHC2021
+-- GHC2024
+-- Unsafe
+-- Trustworthy
+-- Safe
+-- CPP
+-- NoCPP
+-- ...
+-- @
+--
+-- If we're missing a language edition from `knownLanguages` then we'll notice
+-- this omission as it will appear in the unregistered list.
+langsAsExts :: [Extension]
+langsAsExts = map (readExtension . prettyShow) knownLanguages
+
+checkProblems :: [Extension] -> [String]
+checkProblems implemented =
+ -- Extensions that ghc knows about but that are not registered except for the known languages.
+ let unregistered = [ext | ext <- implemented, not (registered ext), ext `notElem` langsAsExts]
+
+ -- check if someone has forgotten to update the `langsAsExts` exceptions list...
+ badExceptions = langsAsExts \\ implemented
+
+ -- exceptions that are now registered
+ badExceptions' = filter registered langsAsExts
+ in catMaybes
+ [ check unregistered $
+ unlines
+ [ "The following extensions are known to GHC but are not in the "
+ , "extension registry in Language.Haskell.Extension."
+ , " " ++ intercalate "\n " (map display unregistered)
+ , "All extensions should be registered, even experimental extensions."
+ ]
+ , check badExceptions $
+ unlines
+ [ "Error in the extension exception list. The following extensions"
+ , "are listed as exceptions but are not even implemented by GHC:"
+ , " " ++ intercalate "\n " (map display badExceptions)
+ , "Please fix this test program by correcting the list of"
+ , "exceptions."
+ ]
+ , check badExceptions' $
+ unlines
+ [ "Error in the extension exception list. The following extensions"
+ , "are listed as exceptions to registration but they are in fact"
+ , "now registered in Language.Haskell.Extension:"
+ , " " ++ intercalate "\n " (map display badExceptions')
+ , "Please fix this test program by correcting the list of"
+ , "exceptions."
+ ]
+ ]
+ where
+ registered UnknownExtension{} = False
+ registered EnableExtension{} = True
+ registered DisableExtension{} = True
+
+ check [] _ = Nothing
+ check _ i = Just i
+
+main :: IO a
+main = do
+ getArgs >>= \case
+ [ghcPath] -> do
+ exts <- getExtensions ghcPath
+ let problems = checkProblems exts
+ putStrLn (intercalate "\n" problems)
+ if null problems
+ then exitSuccess
+ else exitFailure
+ args -> do
+ n <- getProgName
+ putStrLn $ "Error: Got " ++ show (length args) ++ " arguments" ++ if null args then "." else ": " ++ show args ++ "."
+ putStrLn $ "Usage: Supply the path to ghc as a single argument to " ++ n ++ "."
+ exitFailure
+
+getExtensions :: FilePath -> IO [Extension]
+getExtensions ghcPath =
+ map readExtension . lines
+ <$> rawSystemStdout (Verbosity normal defaultVerbosityHandles) ghcPath ["--supported-languages"]
+
+-- | Reads extensions. Anything unknown becomes an `UnknownExtension`.
+--
+-- >>> readExtension "Haskell98"
+-- UnknownExtension "Haskell98"
+readExtension :: String -> Extension
+readExtension str = handleNoParse $ do
+ -- GHC defines extensions in a positive way, Cabal defines them
+ -- relative to H98 so we try parsing ("No" ++ extName) first
+ ext <- simpleParse ("No" ++ str)
+ case ext of
+ UnknownExtension _ -> simpleParse str
+ _ -> return ext
+ where
+ handleNoParse :: Maybe Extension -> Extension
+ handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str)
diff --git a/Cabal-tests/lib/Test/Utils/TempTestDir.hs b/Cabal-tests/lib/Test/Utils/TempTestDir.hs
index 043e8c2d16e..af565ff5154 100644
--- a/Cabal-tests/lib/Test/Utils/TempTestDir.hs
+++ b/Cabal-tests/lib/Test/Utils/TempTestDir.hs
@@ -12,7 +12,7 @@ import Distribution.Verbosity
import Control.Concurrent (threadDelay)
import Control.Exception (throwIO, try)
-import Control.Monad (when)
+import Control.Monad (unless, when)
import Control.Monad.Catch ( bracket, MonadMask)
import Control.Monad.IO.Class
@@ -40,7 +40,7 @@ withTestDir' verbosity tempFileOpts template action = do
(liftIO
-- This ensures that the temp files are not deleted at the end of the test.
-- It replicates the behavior of @withTempDirectoryEx@.
- . when (not (optKeepTempFiles tempFileOpts))
+ . unless (optKeepTempFiles tempFileOpts)
-- This is the bit that helps with Windows deleting all files.
. removeDirectoryRecursiveHack verbosity
)
diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs
index a53d404dd1e..323597eea82 100644
--- a/Cabal-tests/tests/NoThunks.hs
+++ b/Cabal-tests/tests/NoThunks.hs
@@ -129,8 +129,8 @@ deriving via (OnlyCheckWhnf LicenseId) instance NoThunks LicenseId
deriving via (OnlyCheckWhnf LicenseExceptionId) instance NoThunks LicenseExceptionId
deriving via (CheckFoldableNamed NonEmptySet a) instance NoThunks a => NoThunks (NonEmptySet a)
-instance (NoThunks v, NoThunks c, NoThunks a) => NoThunks (CondTree v c a)
-instance (NoThunks v, NoThunks c, NoThunks a) => NoThunks (CondBranch v c a)
+instance (NoThunks v, NoThunks a) => NoThunks (CondTree v a)
+instance (NoThunks v, NoThunks a) => NoThunks (CondBranch v a)
instance (NoThunks c) => NoThunks (Condition c)
-------------------------------------------------------------------------------
diff --git a/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr b/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr
index 3ddf33fb1df..56506e4be74 100644
--- a/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/Octree-0.5.expr
@@ -159,25 +159,6 @@ GenericPackageDescription {
(mkVersion [2, 4, 0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 0]))
- (EarlierVersion
- (mkVersion [4, 7])))
- mainLibSet,
- Dependency
- (PackageName "AC-Vector")
- (OrLaterVersion
- (mkVersion [2, 3, 0]))
- mainLibSet,
- Dependency
- (PackageName "QuickCheck")
- (OrLaterVersion
- (mkVersion [2, 4, 0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
@@ -269,25 +250,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 0]))
- (EarlierVersion
- (mkVersion [4, 7])))
- mainLibSet,
- Dependency
- (PackageName "AC-Vector")
- (OrLaterVersion
- (mkVersion [2, 3, 0]))
- mainLibSet,
- Dependency
- (PackageName "QuickCheck")
- (OrLaterVersion
- (mkVersion [2, 4, 0]))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName "readme")
@@ -377,28 +339,5 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 0]))
- (EarlierVersion
- (mkVersion [4, 7])))
- mainLibSet,
- Dependency
- (PackageName "AC-Vector")
- (OrLaterVersion
- (mkVersion [2, 3, 0]))
- mainLibSet,
- Dependency
- (PackageName "QuickCheck")
- (OrLaterVersion
- (mkVersion [2, 4, 0]))
- mainLibSet,
- Dependency
- (PackageName "markdown-unlit")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/anynone.expr b/Cabal-tests/tests/ParserTests/regressions/anynone.expr
index e2504a9be74..633b942dc98 100644
--- a/Cabal-tests/tests/ParserTests/regressions/anynone.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/anynone.expr
@@ -108,11 +108,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/big-version.expr b/Cabal-tests/tests/ParserTests/regressions/big-version.expr
index 4764da0d35e..76cd8efbab2 100644
--- a/Cabal-tests/tests/ParserTests/regressions/big-version.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/big-version.expr
@@ -105,7 +105,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr b/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr
index 6e1c25f7c66..c18e87f3951 100644
--- a/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/common-conditional.expr
@@ -125,11 +125,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "ghc-prim")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -211,19 +206,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 10]))
- (EarlierVersion
- (mkVersion [4, 11])))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -297,11 +279,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condBranchIfFalse = Nothing}]},
@@ -379,11 +356,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "HUnit")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -454,7 +426,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -538,19 +509,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 10]))
- (EarlierVersion
- (mkVersion [4, 11])))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -625,11 +583,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -705,11 +658,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condBranchIfFalse = Nothing}]}],
diff --git a/Cabal-tests/tests/ParserTests/regressions/common.expr b/Cabal-tests/tests/ParserTests/regressions/common.expr
index 67e4584eb12..eccc70ea5f2 100644
--- a/Cabal-tests/tests/ParserTests/regressions/common.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/common.expr
@@ -123,11 +123,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "ghc-prim")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
@@ -203,10 +198,5 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "HUnit")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/common2.expr b/Cabal-tests/tests/ParserTests/regressions/common2.expr
index 3305120e552..3f967bd20fb 100644
--- a/Cabal-tests/tests/ParserTests/regressions/common2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/common2.expr
@@ -131,23 +131,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 10]))
- (EarlierVersion
- (mkVersion [4, 11])))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "ghc-prim")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -221,11 +204,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condSubLibraries = [
@@ -316,23 +294,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 10]))
- (EarlierVersion
- (mkVersion [4, 11])))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "ghc-prim")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -408,11 +369,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}],
condForeignLibs = [],
@@ -500,23 +456,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 10]))
- (EarlierVersion
- (mkVersion [4, 11])))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "HUnit")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -591,11 +530,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -671,11 +605,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -747,7 +676,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/common3.expr b/Cabal-tests/tests/ParserTests/regressions/common3.expr
index e8fb48890f2..e7c5119b1c3 100644
--- a/Cabal-tests/tests/ParserTests/regressions/common3.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/common3.expr
@@ -123,11 +123,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "ghc-prim")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
@@ -215,22 +210,5 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 10]))
- (EarlierVersion
- (mkVersion [4, 11])))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "HUnit")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/elif.expr b/Cabal-tests/tests/ParserTests/regressions/elif.expr
index 66ce6c0177d..12949a0debd 100644
--- a/Cabal-tests/tests/ParserTests/regressions/elif.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/elif.expr
@@ -114,7 +114,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -188,11 +187,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condSubLibraries = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/elif2.expr b/Cabal-tests/tests/ParserTests/regressions/elif2.expr
index 8e3adc55f10..ac961710014 100644
--- a/Cabal-tests/tests/ParserTests/regressions/elif2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/elif2.expr
@@ -114,7 +114,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -188,11 +187,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Just
CondNode {
@@ -260,7 +254,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -334,11 +327,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Just
CondNode {
@@ -406,7 +394,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []}}]}}]},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr b/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr
index ac6faddb538..0a43104f5d6 100644
--- a/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/encoding-0.8.expr
@@ -131,15 +131,6 @@ GenericPackageDescription {
(mkVersion [4, 4])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (UnionVersionRanges
- (LaterVersion
- (mkVersion [4, 4]))
- (ThisVersion
- (mkVersion [4, 4])))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr b/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr
index 83123587f31..7b7997d78e9 100644
--- a/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/generics-sop.expr
@@ -283,39 +283,6 @@ GenericPackageDescription {
(mkVersion [1, 5])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 7]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "template-haskell")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [2, 8]))
- (EarlierVersion
- (mkVersion [2, 13])))
- mainLibSet,
- Dependency
- (PackageName "ghc-prim")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 3]))
- (EarlierVersion
- (mkVersion [0, 6])))
- mainLibSet,
- Dependency
- (PackageName "deepseq")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [1, 3]))
- (EarlierVersion
- (mkVersion [1, 5])))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -393,15 +360,6 @@ GenericPackageDescription {
(mkVersion [0, 9])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "tagged")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 7]))
- (EarlierVersion
- (mkVersion [0, 9])))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -489,24 +447,6 @@ GenericPackageDescription {
(mkVersion [0, 6])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName
- "transformers-compat")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 3]))
- (EarlierVersion
- (mkVersion [0, 6])))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 3]))
- (EarlierVersion
- (mkVersion [0, 6])))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -579,7 +519,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -652,7 +591,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condSubLibraries = [],
@@ -742,19 +680,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "doctest")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 13]))
- (EarlierVersion
- (mkVersion [0, 14])))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName
@@ -838,18 +763,5 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 6]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "generics-sop")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr b/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr
index 80c5927a1a1..46e1638fcdf 100644
--- a/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/hasktorch.expr
@@ -403,79 +403,6 @@ GenericPackageDescription {
(mkVersion [0, 0, 2])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "dimensions")
- (UnionVersionRanges
- (ThisVersion (mkVersion [1, 0]))
- (LaterVersion
- (mkVersion [1, 0])))
- mainLibSet,
- Dependency
- (PackageName "safe-exceptions")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 1, 0]))
- (LaterVersion
- (mkVersion [0, 1, 0])))
- mainLibSet,
- Dependency
- (PackageName "singletons")
- (UnionVersionRanges
- (ThisVersion (mkVersion [2, 2]))
- (LaterVersion
- (mkVersion [2, 2])))
- mainLibSet,
- Dependency
- (PackageName "text")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [1, 2, 2]))
- (LaterVersion
- (mkVersion [1, 2, 2])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-cpu")])),
- Dependency
- (PackageName "hasktorch-ffi-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-types-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -654,7 +581,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -908,16 +834,6 @@ GenericPackageDescription {
(UnqualComponentName
"hasktorch-gpu")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-gpu")]))],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -1102,7 +1018,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condBranchIfFalse = Nothing}]},
@@ -2598,100 +2513,6 @@ GenericPackageDescription {
"Torch.Sig.Tensor.Random.THC")
(ModuleName
"Torch.Undefined.Double.Tensor.Random.THC")]}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-types-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName "dimensions")
- (UnionVersionRanges
- (ThisVersion (mkVersion [1, 0]))
- (LaterVersion
- (mkVersion [1, 0])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch-ffi-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-types-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName "safe-exceptions")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 1, 0]))
- (LaterVersion
- (mkVersion [0, 1, 0])))
- mainLibSet,
- Dependency
- (PackageName "singletons")
- (UnionVersionRanges
- (ThisVersion (mkVersion [2, 2]))
- (LaterVersion
- (mkVersion [2, 2])))
- mainLibSet,
- Dependency
- (PackageName "text")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [1, 2, 2]))
- (LaterVersion
- (mkVersion [1, 2, 2])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-indef-floating")])),
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-indef-signed")]))],
condTreeComponents =
[
CondBranch {
@@ -2764,7 +2585,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse =
Just
@@ -4862,16 +4682,6 @@ GenericPackageDescription {
"Torch.Sig.Tensor.Random.THC")
(ModuleName
"Torch.Undefined.Float.Tensor.Random.THC")]}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-indef-unsigned")]))],
condTreeComponents = []}}]},
_×_
(UnqualComponentName
@@ -6267,124 +6077,6 @@ GenericPackageDescription {
"Torch.Sig.Tensor.Random.THC")
(ModuleName
"Torch.FFI.THC.Double.TensorRandom")]}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-types-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName "dimensions")
- (UnionVersionRanges
- (ThisVersion (mkVersion [1, 0]))
- (LaterVersion
- (mkVersion [1, 0])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch-ffi-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-types-th")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName "safe-exceptions")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 1, 0]))
- (LaterVersion
- (mkVersion [0, 1, 0])))
- mainLibSet,
- Dependency
- (PackageName "singletons")
- (UnionVersionRanges
- (ThisVersion (mkVersion [2, 2]))
- (LaterVersion
- (mkVersion [2, 2])))
- mainLibSet,
- Dependency
- (PackageName "text")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [1, 2, 2]))
- (LaterVersion
- (mkVersion [1, 2, 2])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-indef-floating")])),
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-indef-signed")])),
- Dependency
- (PackageName
- "hasktorch-ffi-thc")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-types-thc")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet],
condTreeComponents =
[
CondBranch {
@@ -6457,7 +6149,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse =
Just
@@ -7854,16 +7545,6 @@ GenericPackageDescription {
"Torch.Sig.Tensor.Math.Pointwise.Signed")
(ModuleName
"Torch.FFI.THC.Int.TensorMathPointwise")]}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-indef-unsigned")]))],
condTreeComponents = []}}]},
_×_
(UnqualComponentName
@@ -8312,33 +7993,6 @@ GenericPackageDescription {
"Torch.Sig.Tensor.Random.THC")
(ModuleName
"Torch.Undefined.Tensor.Random.THC")]}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-signatures-partial")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch-indef")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName
@@ -8798,33 +8452,6 @@ GenericPackageDescription {
"Torch.Sig.Tensor.Random.THC")
(ModuleName
"Torch.Undefined.Tensor.Random.THC")]}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-signatures-partial")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch-indef")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName
@@ -9504,33 +9131,6 @@ GenericPackageDescription {
(mkVersion [0, 0, 2])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch-indef")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName
- "hasktorch-signatures-partial")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 0, 1]))
- (LaterVersion
- (mkVersion [0, 0, 1])))
- (EarlierVersion
- (mkVersion [0, 0, 2])))
- mainLibSet],
condTreeComponents = []}],
condForeignLibs = [],
condExecutables = [
@@ -9621,26 +9221,6 @@ GenericPackageDescription {
(UnqualComponentName
"hasktorch-cpu")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-cpu")]))],
condTreeComponents = []},
_×_
(UnqualComponentName
@@ -9729,26 +9309,6 @@ GenericPackageDescription {
(UnqualComponentName
"hasktorch-gpu")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "hasktorch-gpu")]))],
condTreeComponents = []},
_×_
(UnqualComponentName
@@ -9832,21 +9392,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName "memcheck")
@@ -9929,21 +9474,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [
_×_
@@ -10141,108 +9671,5 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "QuickCheck")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [2, 11]))
- (LaterVersion
- (mkVersion [2, 11])))
- mainLibSet,
- Dependency
- (PackageName "backprop")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 2, 5]))
- (LaterVersion
- (mkVersion [0, 2, 5])))
- mainLibSet,
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (UnionVersionRanges
- (ThisVersion (mkVersion [4, 7]))
- (LaterVersion
- (mkVersion [4, 7])))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "dimensions")
- (UnionVersionRanges
- (ThisVersion (mkVersion [1, 0]))
- (LaterVersion
- (mkVersion [1, 0])))
- mainLibSet,
- Dependency
- (PackageName
- "ghc-typelits-natnormalise")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "hasktorch")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "hspec")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [2, 4, 4]))
- (LaterVersion
- (mkVersion [2, 4, 4])))
- mainLibSet,
- Dependency
- (PackageName "singletons")
- (UnionVersionRanges
- (ThisVersion (mkVersion [2, 2]))
- (LaterVersion
- (mkVersion [2, 2])))
- mainLibSet,
- Dependency
- (PackageName "mtl")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [2, 2, 2]))
- (LaterVersion
- (mkVersion [2, 2, 2])))
- mainLibSet,
- Dependency
- (PackageName
- "microlens-platform")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 3, 10]))
- (LaterVersion
- (mkVersion [0, 3, 10])))
- mainLibSet,
- Dependency
- (PackageName "monad-loops")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 4, 3]))
- (LaterVersion
- (mkVersion [0, 4, 3])))
- mainLibSet,
- Dependency
- (PackageName "time")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [1, 8, 0]))
- (LaterVersion
- (mkVersion [1, 8, 0])))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [0, 5, 5]))
- (LaterVersion
- (mkVersion [0, 5, 5])))
- mainLibSet,
- Dependency
- (PackageName "generic-lens")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr b/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr
index 47647f9b9cf..c9c82f12a98 100644
--- a/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/hidden-main-lib.expr
@@ -110,11 +110,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/indentation.expr b/Cabal-tests/tests/ParserTests/regressions/indentation.expr
index 9164dace33a..4e52f7ffa7e 100644
--- a/Cabal-tests/tests/ParserTests/regressions/indentation.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/indentation.expr
@@ -115,7 +115,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/indentation2.expr b/Cabal-tests/tests/ParserTests/regressions/indentation2.expr
index 3f7612ef50f..28bc91409bd 100644
--- a/Cabal-tests/tests/ParserTests/regressions/indentation2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/indentation2.expr
@@ -108,7 +108,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/indentation3.expr b/Cabal-tests/tests/ParserTests/regressions/indentation3.expr
index 87d3376c648..d6cd560152e 100644
--- a/Cabal-tests/tests/ParserTests/regressions/indentation3.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/indentation3.expr
@@ -110,7 +110,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr b/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr
index 5fcae0b709b..42d2a3d45df 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-5055.expr
@@ -117,15 +117,6 @@ GenericPackageDescription {
(mkVersion [5])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 8]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [
_×_
@@ -204,15 +195,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 8]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -283,7 +265,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr b/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr
index 44d61d1d795..33462aac3f4 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-5846.expr
@@ -139,43 +139,6 @@ GenericPackageDescription {
LSubLibName
(UnqualComponentName "b")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "lib1")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName "a"),
- LSubLibName
- (UnqualComponentName "b")])),
- Dependency
- (PackageName "lib2")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName "c")])),
- Dependency
- (PackageName "lib3")
- (OrLaterVersion (mkVersion [1]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName "d")])),
- Dependency
- (PackageName "lib4")
- (OrLaterVersion (mkVersion [1]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName "a"),
- LSubLibName
- (UnqualComponentName "b")]))],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr b/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr
index 876c944b620..404d455c918 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-6083-a.expr
@@ -116,20 +116,6 @@ GenericPackageDescription {
(UnqualComponentName
"sublib")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "sublib")]))],
condTreeComponents = []},
condSubLibraries = [
_×_
@@ -201,7 +187,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []}],
condForeignLibs = [],
condExecutables = [
@@ -278,15 +263,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "sublib")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName "demo-b")
@@ -366,20 +342,6 @@ GenericPackageDescription {
(UnqualComponentName
"sublib")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "sublib")]))],
condTreeComponents = []}],
condTestSuites = [],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr b/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr
index 14eb64397df..72a8e6cbfc3 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-6083-b.expr
@@ -116,20 +116,6 @@ GenericPackageDescription {
(UnqualComponentName
"sublib")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "sublib")]))],
condTreeComponents = []},
condSubLibraries = [
_×_
@@ -201,7 +187,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []}],
condForeignLibs = [],
condExecutables = [
@@ -283,20 +268,6 @@ GenericPackageDescription {
(UnqualComponentName
"sublib")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "sublib")]))],
condTreeComponents = []},
_×_
(UnqualComponentName "demo-b")
@@ -376,20 +347,6 @@ GenericPackageDescription {
(UnqualComponentName
"sublib")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "sublib")]))],
condTreeComponents = []}],
condTestSuites = [],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr b/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr
index 4d4450a78cb..9f419d98afd 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-6083-c.expr
@@ -116,20 +116,6 @@ GenericPackageDescription {
(UnqualComponentName
"sublib")]))],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "issue")
- (OrLaterVersion (mkVersion [0]))
- (NonEmptySet.fromNonEmpty
- (NE.fromList
- [
- LSubLibName
- (UnqualComponentName
- "sublib")]))],
condTreeComponents = []},
condSubLibraries = [
_×_
@@ -201,7 +187,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []}],
condForeignLibs = [],
condExecutables = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr b/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr
index c38bd51f941..514a56d9323 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-6083-pkg-pkg.expr
@@ -111,15 +111,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "freetype")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "freetype")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/issue-774.expr b/Cabal-tests/tests/ParserTests/regressions/issue-774.expr
index 31ea274249e..84baff7b936 100644
--- a/Cabal-tests/tests/ParserTests/regressions/issue-774.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/issue-774.expr
@@ -117,7 +117,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr b/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr
index bf3803b9417..96095055228 100644
--- a/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/jaeger-flamegraph.expr
@@ -161,20 +161,6 @@ GenericPackageDescription {
(mkVersion [2, 12, 6, 1]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (UnionVersionRanges
- (MajorBoundVersion
- (mkVersion [4, 11, 1, 0]))
- (MajorBoundVersion
- (mkVersion [4, 12, 0, 0])))
- mainLibSet,
- Dependency
- (PackageName "QuickCheck")
- (MajorBoundVersion
- (mkVersion [2, 12, 6, 1]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
@@ -294,51 +280,6 @@ GenericPackageDescription {
(mkVersion [1, 2, 3, 1]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (UnionVersionRanges
- (MajorBoundVersion
- (mkVersion [4, 11, 1, 0]))
- (MajorBoundVersion
- (mkVersion [4, 12, 0, 0])))
- mainLibSet,
- Dependency
- (PackageName
- "jaeger-flamegraph")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (MajorBoundVersion
- (mkVersion [0, 10, 8, 2]))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (MajorBoundVersion
- (mkVersion [0, 6, 0, 1]))
- mainLibSet,
- Dependency
- (PackageName "extra")
- (MajorBoundVersion
- (mkVersion [1, 6, 13]))
- mainLibSet,
- Dependency
- (PackageName "aeson")
- (MajorBoundVersion
- (mkVersion [1, 4, 1, 0]))
- mainLibSet,
- Dependency
- (PackageName
- "optparse-applicative")
- (MajorBoundVersion
- (mkVersion [0, 14, 3, 0]))
- mainLibSet,
- Dependency
- (PackageName "text")
- (MajorBoundVersion
- (mkVersion [1, 2, 3, 1]))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [
_×_
@@ -447,34 +388,5 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (UnionVersionRanges
- (MajorBoundVersion
- (mkVersion [4, 11, 1, 0]))
- (MajorBoundVersion
- (mkVersion [4, 12, 0, 0])))
- mainLibSet,
- Dependency
- (PackageName
- "jaeger-flamegraph")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "tasty")
- (MajorBoundVersion
- (mkVersion [1, 1, 0, 4]))
- mainLibSet,
- Dependency
- (PackageName "tasty-hspec")
- (MajorBoundVersion
- (mkVersion [1, 1, 5]))
- mainLibSet,
- Dependency
- (PackageName "tasty-quickcheck")
- (MajorBoundVersion
- (mkVersion [0, 10]))
- mainLibSet],
condTreeComponents = []}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr b/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr
index e8d07f99d94..8179e0b4c5c 100644
--- a/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/leading-comma-2.expr
@@ -137,31 +137,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "deepseq")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "filepath")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "directory")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr b/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr
index 15d01d4703d..917f0061cd8 100644
--- a/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/leading-comma.expr
@@ -130,31 +130,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "deepseq")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "filepath")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "directory")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/libpq1.expr b/Cabal-tests/tests/ParserTests/regressions/libpq1.expr
index e3f93b194a4..ca27062bbbf 100644
--- a/Cabal-tests/tests/ParserTests/regressions/libpq1.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/libpq1.expr
@@ -215,23 +215,6 @@ GenericPackageDescription {
(mkVersion [0, 11])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 3]))
- (EarlierVersion
- (mkVersion [4, 13])))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 9, 1, 0]))
- (EarlierVersion
- (mkVersion [0, 11])))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -309,15 +292,6 @@ GenericPackageDescription {
(mkVersion [2, 8])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [2, 4, 2, 0]))
- (EarlierVersion
- (mkVersion [2, 8])))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -396,15 +370,6 @@ GenericPackageDescription {
(mkVersion [2, 7])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [2, 2, 0, 2]))
- (EarlierVersion
- (mkVersion [2, 7])))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -482,7 +447,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Just
CondNode {
@@ -550,7 +514,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -620,7 +583,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Just
CondNode {
@@ -688,7 +650,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -758,7 +719,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse =
Nothing}]}}]}}]},
diff --git a/Cabal-tests/tests/ParserTests/regressions/libpq2.expr b/Cabal-tests/tests/ParserTests/regressions/libpq2.expr
index 0e0403dd8c0..22622665664 100644
--- a/Cabal-tests/tests/ParserTests/regressions/libpq2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/libpq2.expr
@@ -220,23 +220,6 @@ GenericPackageDescription {
(mkVersion [0, 11])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 3]))
- (EarlierVersion
- (mkVersion [4, 13])))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 9, 1, 0]))
- (EarlierVersion
- (mkVersion [0, 11])))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -314,15 +297,6 @@ GenericPackageDescription {
(mkVersion [2, 8])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [2, 4, 2, 0]))
- (EarlierVersion
- (mkVersion [2, 8])))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -401,15 +375,6 @@ GenericPackageDescription {
(mkVersion [2, 7])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "Win32")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [2, 2, 0, 2]))
- (EarlierVersion
- (mkVersion [2, 7])))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -484,7 +449,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Just
CondNode {
@@ -552,7 +516,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -622,7 +585,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Just
CondNode {
@@ -690,7 +652,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -760,7 +721,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse =
Nothing}]}}]}}]},
diff --git a/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr b/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr
index 1b9640c92a5..2266f128631 100644
--- a/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/mixin-1.expr
@@ -147,19 +147,6 @@ GenericPackageDescription {
(ModuleName "Str.ByteString")],
includeRequiresRn =
DefaultRenaming}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "str-string")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "str-bytestring")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr b/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr
index decc098f78f..f025e7b6d40 100644
--- a/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/mixin-2.expr
@@ -147,19 +147,6 @@ GenericPackageDescription {
(ModuleName "Str.ByteString")],
includeRequiresRn =
DefaultRenaming}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "str-string")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "str-bytestring")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr b/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr
index e5278af9017..98e1eac5016 100644
--- a/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/mixin-3.expr
@@ -130,19 +130,6 @@ GenericPackageDescription {
[ModuleName "Foo"],
includeRequiresRn =
DefaultRenaming}}]}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "str-string")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "str-bytestring")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/monad-param.expr b/Cabal-tests/tests/ParserTests/regressions/monad-param.expr
index 8ab441164a5..5193599b8ec 100644
--- a/Cabal-tests/tests/ParserTests/regressions/monad-param.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/monad-param.expr
@@ -141,19 +141,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "mtl")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "stm")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr b/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr
index d9b82eb2aec..c7a7bc8c2e6 100644
--- a/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/multiple-libs-2.expr
@@ -110,11 +110,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [
_×_
@@ -191,11 +186,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condForeignLibs = [],
condExecutables = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/noVersion.expr b/Cabal-tests/tests/ParserTests/regressions/noVersion.expr
index 1384c3eef4a..caebbbd39d1 100644
--- a/Cabal-tests/tests/ParserTests/regressions/noVersion.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/noVersion.expr
@@ -110,11 +110,6 @@ GenericPackageDescription {
(EarlierVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "bad-package")
- (EarlierVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr b/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr
index 0bbfcbbbbac..da94a75b495 100644
--- a/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/nothing-unicode.expr
@@ -121,7 +121,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -191,7 +190,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condSubLibraries = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/shake.expr b/Cabal-tests/tests/ParserTests/regressions/shake.expr
index 46b3bfa2729..1ba7e9a569f 100644
--- a/Cabal-tests/tests/ParserTests/regressions/shake.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/shake.expr
@@ -388,80 +388,6 @@ GenericPackageDescription {
(mkVersion [1, 1]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion
- (mkVersion [4, 5]))
- mainLibSet,
- Dependency
- (PackageName "directory")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "hashable")
- (OrLaterVersion
- (mkVersion [1, 1, 2, 3]))
- mainLibSet,
- Dependency
- (PackageName "binary")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "filepath")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "process")
- (OrLaterVersion
- (mkVersion [1, 1]))
- mainLibSet,
- Dependency
- (PackageName
- "unordered-containers")
- (OrLaterVersion
- (mkVersion [0, 2, 1]))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "utf8-string")
- (OrLaterVersion
- (mkVersion [0, 3]))
- mainLibSet,
- Dependency
- (PackageName "time")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "random")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "js-jquery")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "js-flot")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (OrLaterVersion
- (mkVersion [0, 2]))
- mainLibSet,
- Dependency
- (PackageName "extra")
- (OrLaterVersion
- (mkVersion [1, 4, 8]))
- mainLibSet,
- Dependency
- (PackageName "deepseq")
- (OrLaterVersion
- (mkVersion [1, 1]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -531,7 +457,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -605,11 +530,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "old-time")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condBranchIfFalse = Just
@@ -678,7 +598,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -753,12 +672,6 @@ GenericPackageDescription {
(mkVersion [2, 5, 1]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion
- (mkVersion [2, 5, 1]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}},
CondBranch {
@@ -833,11 +746,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condSubLibraries = [],
@@ -1088,86 +996,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion (mkVersion [4]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "directory")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "hashable")
- (OrLaterVersion
- (mkVersion [1, 1, 2, 3]))
- mainLibSet,
- Dependency
- (PackageName "binary")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "filepath")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "process")
- (OrLaterVersion
- (mkVersion [1, 1]))
- mainLibSet,
- Dependency
- (PackageName
- "unordered-containers")
- (OrLaterVersion
- (mkVersion [0, 2, 1]))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "utf8-string")
- (OrLaterVersion
- (mkVersion [0, 3]))
- mainLibSet,
- Dependency
- (PackageName "time")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "random")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "js-jquery")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "js-flot")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (OrLaterVersion
- (mkVersion [0, 2]))
- mainLibSet,
- Dependency
- (PackageName "extra")
- (OrLaterVersion
- (mkVersion [1, 4, 8]))
- mainLibSet,
- Dependency
- (PackageName "deepseq")
- (OrLaterVersion
- (mkVersion [1, 1]))
- mainLibSet,
- Dependency
- (PackageName "primitive")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -1236,7 +1064,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -1304,7 +1131,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -1375,11 +1201,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "old-time")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condBranchIfFalse = Just
@@ -1445,7 +1266,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -1517,12 +1337,6 @@ GenericPackageDescription {
(mkVersion [2, 5, 1]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion
- (mkVersion [2, 5, 1]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}},
CondBranch {
@@ -1594,11 +1408,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}],
condTestSuites = [
@@ -1893,87 +1702,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion (mkVersion [4]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "directory")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "hashable")
- (OrLaterVersion
- (mkVersion [1, 1, 2, 3]))
- mainLibSet,
- Dependency
- (PackageName "binary")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "filepath")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "process")
- (OrLaterVersion
- (mkVersion [1, 1]))
- mainLibSet,
- Dependency
- (PackageName
- "unordered-containers")
- (OrLaterVersion
- (mkVersion [0, 2, 1]))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "utf8-string")
- (OrLaterVersion
- (mkVersion [0, 3]))
- mainLibSet,
- Dependency
- (PackageName "time")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "random")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "js-jquery")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "js-flot")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "transformers")
- (OrLaterVersion
- (mkVersion [0, 2]))
- mainLibSet,
- Dependency
- (PackageName "deepseq")
- (OrLaterVersion
- (mkVersion [1, 1]))
- mainLibSet,
- Dependency
- (PackageName "extra")
- (OrLaterVersion
- (mkVersion [1, 4, 8]))
- mainLibSet,
- Dependency
- (PackageName "QuickCheck")
- (OrLaterVersion
- (mkVersion [2, 0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -2044,7 +1772,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -2116,7 +1843,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing},
CondBranch {
@@ -2188,7 +1914,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -2263,11 +1988,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "old-time")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]},
condBranchIfFalse = Just
@@ -2337,7 +2057,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -2413,12 +2132,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion
- (mkVersion [2, 5, 1]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}},
CondBranch {
@@ -2494,11 +2207,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "unix")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr b/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr
index d3a3797c1c9..0b673488e8c 100644
--- a/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/spdx-1.expr
@@ -104,7 +104,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr b/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr
index a9c2370712b..909ef7280b2 100644
--- a/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/spdx-2.expr
@@ -108,7 +108,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr b/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr
index 83d37fc29d5..22e97da23a1 100644
--- a/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/spdx-3.expr
@@ -108,7 +108,6 @@ GenericPackageDescription {
customFieldsBI = [],
targetBuildDepends = [],
mixins = []}},
- condTreeConstraints = [],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr b/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr
index 5cd098d5a94..4c9d8cc8467 100644
--- a/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/th-lift-instances.expr
@@ -185,56 +185,6 @@ GenericPackageDescription {
(mkVersion [0, 11])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [4, 4]))
- (EarlierVersion
- (mkVersion [5])))
- mainLibSet,
- Dependency
- (PackageName "template-haskell")
- (EarlierVersion
- (mkVersion [2, 10]))
- mainLibSet,
- Dependency
- (PackageName "th-lift")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 4]))
- (EarlierVersion
- (mkVersion [0, 6])))
- mainLibSet,
- Dependency
- (PackageName "vector")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 9]))
- (EarlierVersion
- (mkVersion [0, 11])))
- mainLibSet,
- Dependency
- (PackageName "text")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 11]))
- (EarlierVersion
- (mkVersion [1, 3])))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 9]))
- (EarlierVersion
- (mkVersion [0, 11])))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
@@ -365,61 +315,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "template-haskell")
- (EarlierVersion
- (mkVersion [2, 10]))
- mainLibSet,
- Dependency
- (PackageName "containers")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 4]))
- (EarlierVersion
- (mkVersion [0, 6])))
- mainLibSet,
- Dependency
- (PackageName "vector")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 9]))
- (EarlierVersion
- (mkVersion [0, 11])))
- mainLibSet,
- Dependency
- (PackageName "text")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 11]))
- (EarlierVersion
- (mkVersion [1, 2])))
- mainLibSet,
- Dependency
- (PackageName "bytestring")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [0, 9]))
- (EarlierVersion
- (mkVersion [0, 11])))
- mainLibSet,
- Dependency
- (PackageName
- "th-lift-instances")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "QuickCheck")
- (IntersectVersionRanges
- (OrLaterVersion
- (mkVersion [2, 6]))
- (EarlierVersion
- (mkVersion [2, 8])))
- mainLibSet],
condTreeComponents = []},
_×_
(UnqualComponentName "doctests")
@@ -507,25 +402,6 @@ GenericPackageDescription {
mainLibSet],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "directory")
- (OrLaterVersion
- (mkVersion [1, 0]))
- mainLibSet,
- Dependency
- (PackageName "doctest")
- (OrLaterVersion
- (mkVersion [0, 9, 1]))
- mainLibSet,
- Dependency
- (PackageName "filepath")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = [
CondBranch {
condBranchCondition =
@@ -596,7 +472,6 @@ GenericPackageDescription {
targetBuildDepends = [],
mixins = []},
testCodeGenerators = []},
- condTreeConstraints = [],
condTreeComponents = []},
condBranchIfFalse = Nothing}]}],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/ParserTests/regressions/version-sets.expr b/Cabal-tests/tests/ParserTests/regressions/version-sets.expr
index 6242af7cb32..5c4248a9530 100644
--- a/Cabal-tests/tests/ParserTests/regressions/version-sets.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/version-sets.expr
@@ -194,71 +194,6 @@ GenericPackageDescription {
(mkVersion [2, 2, 0, 0])))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "network")
- (MajorBoundVersion
- (mkVersion [0]))
- mainLibSet,
- Dependency
- (PackageName "base")
- (ThisVersion (mkVersion [1]))
- mainLibSet,
- Dependency
- (PackageName "base")
- (ThisVersion (mkVersion [1]))
- mainLibSet,
- Dependency
- (PackageName "base")
- (UnionVersionRanges
- (ThisVersion (mkVersion [1]))
- (ThisVersion (mkVersion [2])))
- mainLibSet,
- Dependency
- (PackageName "base")
- (ThisVersion (mkVersion [1, 2]))
- mainLibSet,
- Dependency
- (PackageName "base")
- (UnionVersionRanges
- (ThisVersion (mkVersion [1, 2]))
- (ThisVersion
- (mkVersion [3, 4])))
- mainLibSet,
- Dependency
- (PackageName "ghc")
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [8, 6, 3]))
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [8, 4, 4]))
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [8, 2, 2]))
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [8, 0, 2]))
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [7, 10, 3]))
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [7, 8, 4]))
- (UnionVersionRanges
- (ThisVersion
- (mkVersion [7, 6, 3]))
- (ThisVersion
- (mkVersion [7, 4, 2])))))))))
- mainLibSet,
- Dependency
- (PackageName "Cabal")
- (UnionVersionRanges
- (MajorBoundVersion
- (mkVersion [2, 4, 1, 1]))
- (MajorBoundVersion
- (mkVersion [2, 2, 0, 0])))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
diff --git a/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr b/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr
index 3c9821a1185..f80e366dd84 100644
--- a/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr
+++ b/Cabal-tests/tests/ParserTests/regressions/wl-pprint-indef.expr
@@ -132,16 +132,6 @@ GenericPackageDescription {
(mkVersion [0, 1, 0, 0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (EarlierVersion (mkVersion [5]))
- mainLibSet,
- Dependency
- (PackageName "str-sig")
- (OrLaterVersion
- (mkVersion [0, 1, 0, 0]))
- mainLibSet],
condTreeComponents = []},
condSubLibraries = [],
condForeignLibs = [],
@@ -227,20 +217,6 @@ GenericPackageDescription {
(OrLaterVersion (mkVersion [0]))
mainLibSet],
mixins = []}},
- condTreeConstraints = [
- Dependency
- (PackageName "base")
- (EarlierVersion (mkVersion [5]))
- mainLibSet,
- Dependency
- (PackageName "str-string")
- (OrLaterVersion
- (mkVersion [0, 1, 0, 0]))
- mainLibSet,
- Dependency
- (PackageName "wl-pprint-indef")
- (OrLaterVersion (mkVersion [0]))
- mainLibSet],
condTreeComponents = []}],
condTestSuites = [],
condBenchmarks = []}
diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs
index fd60a79209e..6d4a14c694e 100644
--- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs
+++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs
@@ -30,7 +30,7 @@ argumentTests =
cmdUI = CommandUI
{ commandName = "cmd"
, commandSynopsis = "the command"
- , commandUsage = \name -> name ++ " cmd -v[N]"
+ , commandUsage = (++ " cmd -v[N]")
, commandDescription = Nothing
, commandNotes = Nothing
, commandDefaultFlags = Flag.NoFlag
diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs
index c182f126f03..97b083e0b1c 100644
--- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs
+++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs
@@ -11,7 +11,7 @@ import Distribution.Verbosity
import Data.IORef
import System.Directory ( doesDirectoryExist, doesFileExist
, getTemporaryDirectory
- , removePathForcibly, removeFile )
+ , removePathForcibly )
import System.FilePath ( (<.>) )
import System.IO (hClose, localeEncoding, hPutStrLn)
import System.IO.Error
@@ -32,7 +32,7 @@ withTempFileRemovedTest :: Assertion
withTempFileRemovedTest = do
withTempFile ".foo" $ \fileName handle -> do
hClose handle
- removeFile fileName
+ removeFileForcibly fileName
withTempDirTest :: Assertion
withTempDirTest = do
diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
index eab77f27433..93ec21c5b9f 100644
--- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
+++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
@@ -29,8 +29,8 @@ md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int
md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion
md5CheckGenericPackageDescription proxy = md5Check proxy
- 0xc039c6741dead5203ad2b33bd3bf4dc8
+ 0x9f021aa01a9db87b4270029dc14c5966
md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
md5CheckLocalBuildInfo proxy = md5Check proxy
- 0xe38f63a643a5782e0ee7d16453796142
+ 0x78979713e08179ab070d6ab10cd5ef6c
diff --git a/Cabal-tests/tests/custom-setup/IdrisSetup.hs b/Cabal-tests/tests/custom-setup/IdrisSetup.hs
index 0ba17cab011..20ba0e0a6e5 100644
--- a/Cabal-tests/tests/custom-setup/IdrisSetup.hs
+++ b/Cabal-tests/tests/custom-setup/IdrisSetup.hs
@@ -301,8 +301,8 @@ idrisPostSDist args flags desc lbi = do
let targetFile = "src" "Target_idris" Px.<.> "hs"
putStrLn $ "Removing generated modules:\n "
++ file ++ "\n" ++ targetFile
- removeFile file
- removeFile targetFile)
+ removeFileForcible file
+ removeFileForcible targetFile)
(\e -> let e' = (e :: SomeException) in return ())
postSDist simpleUserHooks args flags desc lbi
#endif
diff --git a/Cabal-tests/tests/misc/ghc-supported-languages.hs b/Cabal-tests/tests/misc/ghc-supported-languages.hs
deleted file mode 100644
index e8036a0364b..00000000000
--- a/Cabal-tests/tests/misc/ghc-supported-languages.hs
+++ /dev/null
@@ -1,97 +0,0 @@
--- | A test program to check that ghc has got all of its extensions registered
---
-module Main where
-
-import Language.Haskell.Extension
-import Distribution.Text
-import Distribution.Simple.Utils
-import Distribution.Verbosity
-
-import Data.List ((\\))
-import Data.Maybe
-import Control.Applicative
-import Control.Monad
-import System.Environment
-import System.Exit
-
--- | A list of GHC extensions that are deliberately not registered,
--- e.g. due to being experimental and not ready for public consumption
---
-exceptions = map readExtension []
-
-checkProblems :: [Extension] -> [String]
-checkProblems implemented =
-
- let unregistered =
- [ ext | ext <- implemented -- extensions that ghc knows about
- , not (registered ext) -- but that are not registered
- , ext `notElem` exceptions ] -- except for the exceptions
-
- -- check if someone has forgotten to update the exceptions list...
-
- -- exceptions that are not implemented
- badExceptions = exceptions \\ implemented
-
- -- exceptions that are now registered
- badExceptions' = filter registered exceptions
-
- in catMaybes
- [ check unregistered $ unlines
- [ "The following extensions are known to GHC but are not in the "
- , "extension registry in Language.Haskell.Extension."
- , " " ++ intercalate "\n " (map display unregistered)
- , "If these extensions are ready for public consumption then they "
- , "should be registered. If they are still experimental and you "
- , "think they are not ready to be registered then please add them "
- , "to the exceptions list in this test program along with an "
- , "explanation."
- ]
- , check badExceptions $ unlines
- [ "Error in the extension exception list. The following extensions"
- , "are listed as exceptions but are not even implemented by GHC:"
- , " " ++ intercalate "\n " (map display badExceptions)
- , "Please fix this test program by correcting the list of"
- , "exceptions."
- ]
- , check badExceptions' $ unlines
- [ "Error in the extension exception list. The following extensions"
- , "are listed as exceptions to registration but they are in fact"
- , "now registered in Language.Haskell.Extension:"
- , " " ++ intercalate "\n " (map display badExceptions')
- , "Please fix this test program by correcting the list of"
- , "exceptions."
- ]
- ]
- where
- registered (UnknownExtension _) = False
- registered _ = True
-
- check [] _ = Nothing
- check _ i = Just i
-
-
-main = topHandler $ do
- [ghcPath] <- getArgs
- exts <- getExtensions ghcPath
- let problems = checkProblems exts
- putStrLn (intercalate "\n" problems)
- if null problems
- then exitSuccess
- else exitFailure
-
-getExtensions :: FilePath -> IO [Extension]
-getExtensions ghcPath =
- map readExtension . lines
- <$> rawSystemStdout normal ghcPath ["--supported-languages"]
-
-readExtension :: String -> Extension
-readExtension str = handleNoParse $ do
- -- GHC defines extensions in a positive way, Cabal defines them
- -- relative to H98 so we try parsing ("No" ++ extName) first
- ext <- simpleParse ("No" ++ str)
- case ext of
- UnknownExtension _ -> simpleParse str
- _ -> return ext
- where
- handleNoParse :: Maybe Extension -> Extension
- handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str)
diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs
index 3f2f2aca9b0..83b0073cf7d 100644
--- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs
+++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs
@@ -41,8 +41,8 @@ import qualified Distribution.Compat.NonEmptySet as NES
-------------------------------------------------------------------------------
instance (Eq a, Show a) => ToExpr (Condition a) where toExpr = defaultExprViaShow
-instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExpr (CondTree a b c)
-instance (Show a, ToExpr b, ToExpr c, Show b, Show c, Eq a, Eq c, Eq b) => ToExpr (CondBranch a b c)
+instance (Show a, ToExpr c, Show c, Eq a, Eq c) => ToExpr (CondTree a c)
+instance (Show a, ToExpr c, Show c, Eq a, Eq c) => ToExpr (CondBranch a c)
instance (ToExpr a) => ToExpr (NubList a)
instance ToExpr a => ToExpr (NES.NonEmptySet a) where
toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs]
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
index 624d9de2a49..c91d2c11d89 100644
--- a/Cabal/Cabal.cabal
+++ b/Cabal/Cabal.cabal
@@ -48,9 +48,8 @@ library
, directory >= 1.2.7 && < 1.4
, filepath >= 1.4.2 && < 1.6
, pretty >= 1.1.1 && < 1.2
- -- segfaults on older macOS versions #11465
- , process >= 1.2.1.0 && < 1.6.24 || == 1.6.26.0 || >= 1.6.26.2 && < 1.7
- , time >= 1.4.0.1 && < 1.16
+ , process >= 1.6.20.0 && < 1.6.24 || == 1.6.26.0 || >= 1.6.26.2 && < 1.7
+ , time >= 1.4.0.1 && < 1.17
if os(windows)
build-depends:
@@ -165,6 +164,7 @@ library
Distribution.Simple.UHC
Distribution.Simple.UserHooks
Distribution.Simple.SetupHooks.Errors
+ Distribution.Simple.SetupHooks.HooksMain
Distribution.Simple.SetupHooks.Internal
Distribution.Simple.SetupHooks.Rule
Distribution.Simple.Utils
diff --git a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs
index aef3db817c6..6ce25d2a323 100644
--- a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs
+++ b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs
@@ -22,6 +22,7 @@ import Distribution.Types.ComponentRequestedSpec
import Distribution.Utils.Generic
import Distribution.Pretty (pretty)
+import GHC.Stack (HasCallStack)
import Text.PrettyPrint
------------------------------------------------------------------------------
@@ -50,7 +51,8 @@ dispComponentsWithDeps graph =
-- | Create a 'Graph' of 'Component', or report a cycle if there is a
-- problem.
mkComponentsGraph
- :: ComponentRequestedSpec
+ :: HasCallStack
+ => ComponentRequestedSpec
-> PackageDescription
-> Either [ComponentName] ComponentsGraph
mkComponentsGraph enabled pkg_descr =
diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs
index 55d1ae03254..611537a7828 100644
--- a/Cabal/src/Distribution/Backpack/Configure.hs
+++ b/Cabal/src/Distribution/Backpack/Configure.hs
@@ -54,6 +54,7 @@ import Data.Either
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Pretty
+import GHC.Stack (HasCallStack)
import Text.PrettyPrint
------------------------------------------------------------------------------
@@ -61,7 +62,8 @@ import Text.PrettyPrint
------------------------------------------------------------------------------
configureComponentLocalBuildInfos
- :: Verbosity
+ :: HasCallStack
+ => Verbosity
-> Bool -- use_external_internal_deps
-> ComponentRequestedSpec
-> Bool -- deterministic
@@ -206,7 +208,8 @@ configureComponentLocalBuildInfos
------------------------------------------------------------------------------
toComponentLocalBuildInfos
- :: Compiler
+ :: HasCallStack
+ => Compiler
-> InstalledPackageIndex -- FULL set
-> [ConfiguredPromisedComponent]
-> PackageDescription
@@ -232,12 +235,12 @@ toComponentLocalBuildInfos
-- 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 :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent)
external_graph =
Graph.fromDistinctList
. map Left
$ PackageIndex.allPackages installedPackageSet
- internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+ internal_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent)
internal_graph =
Graph.fromDistinctList
. map Right
@@ -280,14 +283,14 @@ toComponentLocalBuildInfos
[ "installed package "
++ prettyShow (packageId pkg)
++ " is broken due to missing package "
- ++ intercalate ", " (map prettyShow deps)
+ ++ intercalate ", " (map prettyShow $ toList deps)
| (Left pkg, deps) <- broken
]
++ unlines
[ "planned package "
++ prettyShow (packageId pkg)
++ " is broken due to missing package "
- ++ intercalate ", " (map prettyShow deps)
+ ++ intercalate ", " (map prettyShow $ toList deps)
| (Right pkg, deps) <- broken
]
diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs
index 9fd78352b7c..93da4de37c3 100644
--- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs
+++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs
@@ -94,7 +94,7 @@ dispConfiguredComponent 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.
+-- work this does is handling implicit @mixin@ fields.
mkConfiguredComponent
:: PackageDescription
-> ComponentId
@@ -121,7 +121,7 @@ mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do
}
-- Any @build-depends@ which is not explicitly mentioned in
- -- @backpack-include@ is converted into an "implicit" include.
+ -- @mixin@ is converted into an "implicit" include.
let used_explicitly = Set.fromList (map ci_id explicit_includes)
implicit_includes =
map
diff --git a/Cabal/src/Distribution/Backpack/LinkedComponent.hs b/Cabal/src/Distribution/Backpack/LinkedComponent.hs
index a66240d82e3..d041c715aac 100644
--- a/Cabal/src/Distribution/Backpack/LinkedComponent.hs
+++ b/Cabal/src/Distribution/Backpack/LinkedComponent.hs
@@ -258,7 +258,17 @@ toLinkedComponent
hang
(text "Non-library component has unfilled requirements:")
4
- (vcat [pretty req | req <- Set.toList reqs])
+ ( vcat
+ [ case Map.lookup req (modScopeRequires linked_shape0) of
+ Just srcs@(_ : _) ->
+ hang
+ (pretty req)
+ 4
+ (vcat [text "brought into scope by" <+> dispModuleSource (getSource src) | src <- srcs])
+ _ -> 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
@@ -371,7 +381,7 @@ toLinkedComponent
, lc_component = component
, lc_public = is_public
, -- These must be executables
- lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps
+ lc_exe_deps = map (fmap (`IndefFullUnitId` Map.empty)) exe_deps
, lc_shape = final_linked_shape
, lc_includes = linked_includes
, lc_sig_includes = linked_sig_includes
diff --git a/Cabal/src/Distribution/Backpack/UnifyM.hs b/Cabal/src/Distribution/Backpack/UnifyM.hs
index 39202d00046..d4e1e1a0b0a 100644
--- a/Cabal/src/Distribution/Backpack/UnifyM.hs
+++ b/Cabal/src/Distribution/Backpack/UnifyM.hs
@@ -186,7 +186,7 @@ failIfErrs :: UnifyM s ()
failIfErrs = do
env <- getUnifEnv
errs <- liftST $ readSTRef (unify_errs env)
- when (not (null errs)) failM
+ unless (null errs) failM
tryM :: UnifyM s a -> UnifyM s (Maybe a)
tryM m =
diff --git a/Cabal/src/Distribution/Compat/ResponseFile.hs b/Cabal/src/Distribution/Compat/ResponseFile.hs
index b1124d47cfe..31f172e0715 100644
--- a/Cabal/src/Distribution/Compat/ResponseFile.hs
+++ b/Cabal/src/Distribution/Compat/ResponseFile.hs
@@ -31,4 +31,4 @@ expandResponse = go recursionLimit "."
expand _n _dir x = return [x]
readRecursively :: Int -> FilePath -> IO [String]
- readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f
+ readRecursively n f = go (n - 1) (takeDirectory f) . unescapeArgs =<< readFile f
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index bf9f5fcb394..e27800448b9 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -89,6 +89,8 @@ import qualified Data.Set as Set
import qualified Distribution.Utils.ShortText as ShortText
import qualified Distribution.Utils.String as String
+import qualified Distribution.Compat.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import Control.Monad
@@ -358,11 +360,11 @@ checkGenericPackageDescription
-- once, rather than re-checking in every conditional branch.
let allModuleNames =
Set.fromList $
- maybe [] (explicitLibModules . fst . ignoreConditions) condLibrary_
- ++ concatMap (explicitLibModules . fst . ignoreConditions . snd) condSubLibraries_
- ++ concatMap (exeModules . fst . ignoreConditions . snd) condExecutables_
- ++ concatMap (testModules . fst . ignoreConditions . snd) condTestSuites_
- ++ concatMap (benchmarkModules . fst . ignoreConditions . snd) condBenchmarks_
+ maybe [] (explicitLibModules . ignoreConditions) condLibrary_
+ ++ concatMap (explicitLibModules . ignoreConditions . snd) condSubLibraries_
+ ++ concatMap (exeModules . ignoreConditions . snd) condExecutables_
+ ++ concatMap (testModules . ignoreConditions . snd) condTestSuites_
+ ++ concatMap (benchmarkModules . ignoreConditions . snd) condBenchmarks_
mapM_ (\m -> checkPackageFileNamesWithGlob PathKindFile (toFilePath m)) allModuleNames
where
-- todo is this caught at parse time?
@@ -537,7 +539,7 @@ checkPackageDescription
( isNothing setupBuildInfo_
&& buildTypeRaw_ == Just Custom
)
- (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup)
+ (PackageDistSuspiciousWarn CVExplicitDepsCustomSetup)
checkP
(isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2)
(PackageBuildWarning NoBuildType)
@@ -980,14 +982,14 @@ wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw)
-- each of those branch will be checked one by one.
extractAssocDeps
:: UnqualComponentName -- Name of the target library
- -> CondTree ConfVar [Dependency] Library
+ -> CondTree ConfVar 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)
+ (n, L.view L.targetBuildDepends a)
-- | August 2022: this function is an oddity due to the historical
-- GenericPackageDescription/PackageDescription split (check
@@ -1023,8 +1025,8 @@ pd2gpd pd = gpd
}
-- From target to simple, unconditional CondTree.
- t2c :: a -> CondTree ConfVar [Dependency] a
- t2c a = CondNode a [] []
+ t2c :: a -> CondTree ConfVar 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
@@ -1034,7 +1036,7 @@ pd2gpd pd = gpd
:: (a -> UnqualComponentName)
-> (a -> a)
-> a
- -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
+ -> (UnqualComponentName, CondTree ConfVar a)
t2cName nf mf a = (nf a, t2c . mf $ a)
ln :: Library -> UnqualComponentName
diff --git a/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs b/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs
index 540874c685c..5a18e39c4ee 100644
--- a/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs
@@ -23,7 +23,6 @@ import Prelude ()
import Distribution.Compiler
import Distribution.ModuleName (ModuleName)
-import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Check.Monad
import Distribution.System
@@ -63,21 +62,18 @@ annotateCondTree
. (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) =
+ -> CondTree ConfVar a
+ -> CondTree ConfVar (TargetAnnotation a)
+annotateCondTree fs ta (CondNode a bs) =
let ta' = updateTargetAnnotation a ta
bs' = map (annotateBranch ta') bs
bs'' = crossAnnotateBranches defTrueFlags bs'
- in CondNode ta' c bs''
+ in CondNode ta' bs''
where
annotateBranch
:: TargetAnnotation a
- -> CondBranch ConfVar [Dependency] a
- -> CondBranch
- ConfVar
- [Dependency]
- (TargetAnnotation a)
+ -> CondBranch ConfVar a
+ -> CondBranch ConfVar (TargetAnnotation a)
annotateBranch wta (CondBranch k t mf) =
let uf = isPkgFlagCond k
wta' = wta{taPackageFlag = taPackageFlag wta || uf}
@@ -119,13 +115,13 @@ crossAnnotateBranches
:: forall a
. (Eq a, Monoid a)
=> [PackageFlag] -- `default: true` flags.
- -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]
- -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]
+ -> [CondBranch ConfVar (TargetAnnotation a)]
+ -> [CondBranch ConfVar (TargetAnnotation a)]
crossAnnotateBranches fs bs = map crossAnnBranch bs
where
crossAnnBranch
- :: CondBranch ConfVar [Dependency] (TargetAnnotation a)
- -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+ :: CondBranch ConfVar (TargetAnnotation a)
+ -> CondBranch ConfVar (TargetAnnotation a)
crossAnnBranch wr =
let
rs = filter (/= wr) bs
@@ -133,24 +129,23 @@ crossAnnotateBranches fs bs = map crossAnnBranch bs
in
updateTargetAnnBranch (mconcat ts) wr
- realiseBranch :: CondBranch ConfVar [Dependency] (TargetAnnotation a) -> Maybe a
+ realiseBranch :: CondBranch ConfVar (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
+ simplifyCondBranch realiseBranchFunction (fmap taTarget b)
updateTargetAnnBranch
:: a
- -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
- -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+ -> CondBranch ConfVar (TargetAnnotation a)
+ -> CondBranch ConfVar (TargetAnnotation a)
updateTargetAnnBranch a (CondBranch k t mt) =
- let updateTargetAnnTree (CondNode ka c wbs) =
- (CondNode (updateTargetAnnotation a ka) c wbs)
+ let updateTargetAnnTree (CondNode ka wbs) =
+ (CondNode (updateTargetAnnotation a ka) wbs)
in CondBranch k (updateTargetAnnTree t) (updateTargetAnnTree <$> mt)
-- | A conditional target is a library, exe, benchmark etc., destructured
@@ -165,7 +160,7 @@ checkCondTarget
-- Naming function (some targets
-- need to have their name
-- spoonfed to them.
- -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
+ -> (UnqualComponentName, CondTree ConfVar a)
-- Target name/condtree.
-> CheckM m ()
checkCondTarget fs cf nf (unqualName, ct) =
@@ -174,9 +169,9 @@ checkCondTarget fs cf nf (unqualName, ct) =
-- Walking the tree. Remember that CondTree is not a binary
-- tree but a /rose/tree.
wTree
- :: CondTree ConfVar [Dependency] (TargetAnnotation a)
+ :: CondTree ConfVar (TargetAnnotation a)
-> CheckM m ()
- wTree (CondNode ta _ bs)
+ 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
@@ -192,13 +187,13 @@ checkCondTarget fs cf nf (unqualName, ct) =
mapM_ wBranch bs
isSimple
- :: CondBranch ConfVar [Dependency] (TargetAnnotation a)
+ :: CondBranch ConfVar (TargetAnnotation a)
-> Bool
isSimple (CondBranch _ _ Nothing) = True
isSimple (CondBranch _ _ (Just _)) = False
wBranch
- :: CondBranch ConfVar [Dependency] (TargetAnnotation a)
+ :: CondBranch ConfVar (TargetAnnotation a)
-> CheckM m ()
wBranch (CondBranch k t mf) = do
checkCondVars k
@@ -239,15 +234,16 @@ checkDuplicateModules pkg =
checkExe = checkDups "executable" exeModules
checkTest = checkDups "test suite" testModules
checkBench = checkDups "benchmark" benchmarkModules
- checkDups :: String -> (a -> [ModuleName]) -> CondTree v c a -> [PackageCheck]
+ checkDups :: String -> (a -> [ModuleName]) -> CondTree v 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 :: Map ModuleName (Int, Int)
libMap =
foldCondTree
Map.empty
- (\(_, v) -> Map.fromListWith sumPair . map (,(1, 1)) $ getModules v)
+ (\v -> Map.fromListWith sumPair . map (,(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
diff --git a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
index e91df5bf493..7f333a9c4c8 100644
--- a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
@@ -245,7 +245,7 @@ data CheckExplanation
| CVSourceRepository
| CVExtensions CabalSpecVersion [Extension]
| CVCustomSetup
- | CVExpliticDepsCustomSetup
+ | CVExplicitDepsCustomSetup
| CVAutogenPaths
| CVAutogenPackageInfo
| CVAutogenPackageInfoGuard
@@ -413,7 +413,7 @@ data CheckExplanationID
| CICVSourceRepository
| CICVExtensions
| CICVCustomSetup
- | CICVExpliticDepsCustomSetup
+ | CICVExplicitDepsCustomSetup
| CICVAutogenPaths
| CICVAutogenPackageInfo
| CICVAutogenPackageInfoGuard
@@ -560,7 +560,7 @@ checkExplanationId (CVVirtualModules{}) = CICVVirtualModules
checkExplanationId (CVSourceRepository{}) = CICVSourceRepository
checkExplanationId (CVExtensions{}) = CICVExtensions
checkExplanationId (CVCustomSetup{}) = CICVCustomSetup
-checkExplanationId (CVExpliticDepsCustomSetup{}) = CICVExpliticDepsCustomSetup
+checkExplanationId (CVExplicitDepsCustomSetup{}) = CICVExplicitDepsCustomSetup
checkExplanationId (CVAutogenPaths{}) = CICVAutogenPaths
checkExplanationId (CVAutogenPackageInfo{}) = CICVAutogenPackageInfo
checkExplanationId (CVAutogenPackageInfoGuard{}) = CICVAutogenPackageInfoGuard
@@ -714,7 +714,7 @@ ppCheckExplanationId CICVVirtualModules = "virtual-modules"
ppCheckExplanationId CICVSourceRepository = "source-repository"
ppCheckExplanationId CICVExtensions = "incompatible-extension"
ppCheckExplanationId CICVCustomSetup = "no-setup-depends"
-ppCheckExplanationId CICVExpliticDepsCustomSetup = "dependencies-setup"
+ppCheckExplanationId CICVExplicitDepsCustomSetup = "dependencies-setup"
ppCheckExplanationId CICVAutogenPaths = "no-autogen-paths"
ppCheckExplanationId CICVAutogenPackageInfo = "no-autogen-pinfo"
ppCheckExplanationId CICVAutogenPackageInfoGuard = "autogen-guard"
@@ -1258,7 +1258,7 @@ ppExplanation CVCustomSetup =
++ "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 =
+ppExplanation CVExplicitDepsCustomSetup =
"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' "
diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs
index 114c60a1add..9877e861ea5 100644
--- a/Cabal/src/Distribution/Simple.hs
+++ b/Cabal/src/Distribution/Simple.hs
@@ -14,7 +14,6 @@ libraries/Cabal/Distribution/Simple.hs:78:0:
Deprecated: "Please use the new testing interface instead!"
-}
{-# OPTIONS_GHC -Wno-deprecations #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- |
-- Module : Distribution.Simple
@@ -172,6 +171,15 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles =
, hscolourHook = setup_hscolourHook
}
where
+ preBuildHook =
+ case SetupHooks.preBuildComponentRules (SetupHooks.buildHooks setupHooks) of
+ Nothing -> const $ return []
+ Just pbcRules -> \pbci -> runPreBuildHooks verbHandles pbci pbcRules
+ postBuildHook =
+ case SetupHooks.postBuildComponentHook (SetupHooks.buildHooks setupHooks) of
+ Nothing -> const $ return ()
+ Just hk -> hk
+
setup_confHook
:: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
@@ -189,13 +197,14 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles =
-> BuildFlags
-> IO ()
setup_buildHook pkg_descr lbi hooks flags =
- build_setupHooks
- (SetupHooks.buildHooks setupHooks)
- verbHandles
- pkg_descr
- lbi
- flags
- (allSuffixHandlers hooks)
+ void $
+ build_setupHooks
+ (preBuildHook, postBuildHook)
+ verbHandles
+ pkg_descr
+ lbi
+ flags
+ (allSuffixHandlers hooks)
setup_copyHook
:: PackageDescription
@@ -230,14 +239,15 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles =
-> [String]
-> IO ()
setup_replHook pkg_descr lbi hooks flags args =
- repl_setupHooks
- (SetupHooks.buildHooks setupHooks)
- verbHandles
- pkg_descr
- lbi
- flags
- (allSuffixHandlers hooks)
- args
+ void $
+ repl_setupHooks
+ preBuildHook
+ verbHandles
+ pkg_descr
+ lbi
+ flags
+ (allSuffixHandlers hooks)
+ args
setup_haddockHook
:: PackageDescription
@@ -246,13 +256,14 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles =
-> HaddockFlags
-> IO ()
setup_haddockHook pkg_descr lbi hooks flags =
- haddock_setupHooks
- (SetupHooks.buildHooks setupHooks)
- verbHandles
- pkg_descr
- lbi
- (allSuffixHandlers hooks)
- flags
+ void $
+ haddock_setupHooks
+ preBuildHook
+ verbHandles
+ pkg_descr
+ lbi
+ (allSuffixHandlers hooks)
+ flags
setup_hscolourHook
:: PackageDescription
@@ -261,13 +272,14 @@ defaultMainWithSetupHooksArgs setupHooks verbHandles =
-> HscolourFlags
-> IO ()
setup_hscolourHook pkg_descr lbi hooks flags =
- hscolour_setupHooks
- (SetupHooks.buildHooks setupHooks)
- verbHandles
- pkg_descr
- lbi
- (allSuffixHandlers hooks)
- flags
+ void $
+ hscolour_setupHooks
+ preBuildHook
+ verbHandles
+ pkg_descr
+ lbi
+ (allSuffixHandlers hooks)
+ flags
-- | A customizable version of 'defaultMain'.
defaultMainWithHooks :: UserHooks -> IO ()
@@ -931,12 +943,16 @@ simpleUserHooksWithHandles verbHandles =
, testHook = defaultTestHook verbHandles
, benchHook = defaultBenchHook verbHandles
, cleanHook = \p _ _ f -> clean verbHandles p f
- , hscolourHook = \p l h f -> hscolour_setupHooks SetupHooks.noBuildHooks verbHandles p l (allSuffixHandlers h) f
- , haddockHook = \p l h f -> haddock_setupHooks SetupHooks.noBuildHooks verbHandles p l (allSuffixHandlers h) f
+ , hscolourHook = \p l h f -> void $ hscolour_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f
+ , haddockHook = \p l h f -> void $ haddock_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f
, regHook = defaultRegHook verbHandles
, unregHook = \p l _ f -> unregisterWithHandles verbHandles p l f
}
where
+ noBuildHooks pbci@(SetupHooks.PreBuildComponentInputs{SetupHooks.localBuildInfo = lbi}) =
+ builtinPreBuildHooks
+ (buildType (localPkgDescr lbi))
+ pbci
finalChecks _args flags pkg_descr lbi =
checkForeignDeps pkg_descr lbi (modifyVerbosityFlags lessVerbose verbosity)
where
@@ -1156,13 +1172,14 @@ defaultBuildHook
-> BuildFlags
-> IO ()
defaultBuildHook verbHandles pkg_descr localbuildinfo hooks flags =
- build_setupHooks
- SetupHooks.noBuildHooks
- verbHandles
- pkg_descr
- localbuildinfo
- flags
- (allSuffixHandlers hooks)
+ void $
+ build_setupHooks
+ (builtinPreBuildHooks (buildType pkg_descr), const $ pure ())
+ verbHandles
+ pkg_descr
+ localbuildinfo
+ flags
+ (allSuffixHandlers hooks)
defaultReplHook
:: VerbosityHandles
@@ -1173,14 +1190,15 @@ defaultReplHook
-> [String]
-> IO ()
defaultReplHook verbHandles pkg_descr localbuildinfo hooks flags args =
- repl_setupHooks
- SetupHooks.noBuildHooks
- verbHandles
- pkg_descr
- localbuildinfo
- flags
- (allSuffixHandlers hooks)
- args
+ void $
+ repl_setupHooks
+ (builtinPreBuildHooks (buildType pkg_descr))
+ verbHandles
+ pkg_descr
+ localbuildinfo
+ flags
+ (allSuffixHandlers hooks)
+ args
defaultRegHook
:: VerbosityHandles
diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs
index 86a8133d742..7f8b9f0f069 100644
--- a/Cabal/src/Distribution/Simple/Build.hs
+++ b/Cabal/src/Distribution/Simple/Build.hs
@@ -25,6 +25,7 @@ module Distribution.Simple.Build
( -- * Build
build
, build_setupHooks
+ , buildComponent
-- * Repl
, repl
@@ -33,6 +34,8 @@ module Distribution.Simple.Build
-- * Build preparation
, preBuildComponent
+ , runPreBuildHooks
+ , builtinPreBuildHooks
, AutogenFile (..)
, AutogenFileContents
, writeBuiltinAutogenFiles
@@ -105,9 +108,8 @@ import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Config
import Distribution.Simple.Setup.Repl
import Distribution.Simple.SetupHooks.Internal
- ( BuildHooks (..)
- , BuildingWhat (..)
- , noBuildHooks
+ ( BuildingWhat (..)
+ , buildingWhatVerbosity
)
import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks
import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks
@@ -128,7 +130,6 @@ import Control.Monad
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
-import System.Directory (doesFileExist, removeFile)
import System.FilePath (takeDirectory)
-- -----------------------------------------------------------------------------
@@ -144,10 +145,16 @@ build
-> [PPSuffixHandler]
-- ^ preprocessors to run before compiling
-> IO ()
-build = build_setupHooks noBuildHooks defaultVerbosityHandles
+build pkg lbi flags pps =
+ void $ build_setupHooks noHooks defaultVerbosityHandles pkg lbi flags pps
+ where
+ noHooks = (const $ return [], const $ return ())
build_setupHooks
- :: BuildHooks
+ :: ( SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath]
+ , SetupHooks.PostBuildComponentInputs -> IO ()
+ )
+ -- ^ build hooks
-> VerbosityHandles
-> PackageDescription
-- ^ Mostly information from the .cabal file
@@ -157,14 +164,16 @@ build_setupHooks
-- ^ Flags that the user passed to build
-> [PPSuffixHandler]
-- ^ preprocessors to run before compiling
- -> IO ()
+ -> IO [SetupHooks.MonitorFilePath]
build_setupHooks
- (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild})
+ (preBuildHook, postBuildHook)
verbHandles
pkg_descr
lbi
flags
suffixHandlers = do
+ let verbosity = mkVerbosity verbHandles (fromFlag $ buildVerbosity flags)
+ distPref = fromFlag $ buildDistPref flags
checkSemaphoreSupport verbosity (compiler lbi) flags
targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags)
@@ -193,7 +202,7 @@ build_setupHooks
curDir <- absoluteWorkingDirLBI lbi
-- Now do the actual building
- (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do
+ (mons, _) <- (\f -> foldM f ([], installedPkgs lbi) componentsToBuild) $ \(monsAcc, index) target -> do
let comp = targetComponent target
clbi = targetCLBI target
bi = componentBuildInfo comp
@@ -205,18 +214,8 @@ build_setupHooks
, 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
+ pbci = SetupHooks.PreBuildComponentInputs (BuildNormal flags) lbi' target
+ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target
let numJobs = buildNumJobs flags
par_strat <-
toFlag <$> case buildUseSemaphore flags of
@@ -245,13 +244,10 @@ build_setupHooks
, SetupHooks.localBuildInfo = lbi'
, SetupHooks.targetInfo = target
}
- for_ mbPostBuild ($ postBuildInputs)
- return (maybe index (`Index.insert` index) mb_ipi)
+ postBuildHook postBuildInputs
+ return (monsAcc <> mons, maybe index (`Index.insert` index) mb_ipi)
- return ()
- where
- distPref = fromFlag (buildDistPref flags)
- verbosity = mkVerbosity verbHandles (fromFlag (buildVerbosity flags))
+ return mons
-- | Check for conditions that would prevent the build from succeeding.
checkSemaphoreSupport
@@ -307,10 +303,9 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
++ unlines warns
LBS.writeFile buildInfoFile buildInfoText
- when (not shouldDumpBuildInfo) $ do
+ unless shouldDumpBuildInfo $
-- Remove existing build-info.json as it might be outdated now.
- exists <- doesFileExist buildInfoFile
- when exists $ removeFile buildInfoFile
+ removeFileForcibly buildInfoFile
where
buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref
shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo
@@ -335,11 +330,20 @@ repl
-- ^ preprocessors to run before compiling
-> [String]
-> IO ()
-repl = repl_setupHooks noBuildHooks defaultVerbosityHandles
+repl pkg lbi flags pps args =
+ void $
+ repl_setupHooks
+ (const $ return [])
+ defaultVerbosityHandles
+ pkg
+ lbi
+ flags
+ pps
+ args
repl_setupHooks
- :: BuildHooks
- -- ^ build hook
+ :: (SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath])
+ -- ^ pre-build hook
-> VerbosityHandles
-> PackageDescription
-- ^ Mostly information from the .cabal file
@@ -350,9 +354,9 @@ repl_setupHooks
-> [PPSuffixHandler]
-- ^ preprocessors to run before compiling
-> [String]
- -> IO ()
+ -> IO [SetupHooks.MonitorFilePath]
repl_setupHooks
- (BuildHooks{preBuildComponentRules = mbPbcRules})
+ preBuildHook
verbHandles
pkg_descr
lbi
@@ -396,25 +400,16 @@ repl_setupHooks
(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
+ pbci lbi' tgt = SetupHooks.PreBuildComponentInputs (BuildRepl flags) lbi' tgt
+
+ -- build any dependent components and collect their monitored file paths
+ depMonitors <- fmap concat $ for (safeInit componentsToBuild) $ \subtarget -> do
+ let clbi = targetCLBI subtarget
+ comp = targetComponent subtarget
+ lbi' <- lbiForComponent comp lbi
+ monitors <- preBuildComponent (preBuildHook (pbci lbi' subtarget)) verbosity lbi' subtarget
+
+ _mb_ipi <-
buildComponent
verbHandles
(mempty{buildCommonFlags = mempty{setupVerbosity = toFlag $ verbosityFlags verbosity}})
@@ -425,16 +420,21 @@ repl_setupHooks
comp
clbi
distPref
- | subtarget <- safeInit componentsToBuild
- ]
+
+ return monitors
-- REPL for target components
let clbi = targetCLBI target
comp = targetComponent target
lbi' <- lbiForComponent comp lbi
- preBuildComponent runPreBuildHooks verbosity lbi' target
+
+ targetMonitors <-
+ preBuildComponent (preBuildHook (pbci lbi' target)) verbosity lbi' target
+
replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref
+ return (depMonitors <> targetMonitors)
+
-- | Start an interpreter without loading any package files.
startInterpreter
:: Verbosity
@@ -626,7 +626,7 @@ generateCode
-> 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
+ unless (null codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir
(tgtDir,) . concat <$> mapM go codeGens
where
allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc)
@@ -922,7 +922,7 @@ createInternalPackageDB
createInternalPackageDB verbosity lbi distPref = do
existsAlready <- doesPackageDBExist dbPath
when existsAlready $ deletePackageDB dbPath
- createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
+ createPackageDB verbosity (compiler lbi) (withPrograms lbi) dbPath
return (SpecificPackageDB dbRelPath)
where
dbRelPath = internalPackageDBPath lbi distPref
@@ -1135,20 +1135,53 @@ componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do
-- | Creates the autogenerated files for a particular configured component,
-- and runs the pre-build hook.
preBuildComponent
- :: (LocalBuildInfo -> TargetInfo -> IO ())
+ :: IO r
-- ^ pre-build hook
-> Verbosity
-> LocalBuildInfo
-- ^ Configuration information
-> TargetInfo
- -> IO ()
+ -> IO r
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
+ preBuildHook
+
+-- | Compute and execute 'PreBuildComponentRules', returning the monitored
+-- files declared by the rules.
+runPreBuildHooks
+ :: VerbosityHandles
+ -> SetupHooks.PreBuildComponentInputs
+ -> SetupHooks.PreBuildComponentRules
+ -> IO [SetupHooks.MonitorFilePath]
+runPreBuildHooks
+ verbHandles
+ pbci@( SetupHooks.PreBuildComponentInputs
+ { SetupHooks.buildingWhat = what
+ , SetupHooks.localBuildInfo = lbi
+ , SetupHooks.targetInfo = tgt
+ }
+ )
+ pbcRules = do
+ let verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity what
+ (rules, mons) <- SetupHooks.computeRules verbosity pbci pbcRules
+ SetupHooks.executeRules verbosity lbi tgt rules
+ return mons
+
+-- | Built-in pre-build 'SetupHooks' for a given 'BuildType'.
+builtinPreBuildHooks
+ :: BuildType
+ -> SetupHooks.PreBuildComponentInputs
+ -> IO [SetupHooks.MonitorFilePath]
+builtinPreBuildHooks _ =
+ -- NB: currently there are no built-in pre-build hooks.
+ --
+ -- In the future, we may want to migrate built-in preprocessors (such as
+ -- @hsc2hs@, @alex@, @happy@) to pre-build hooks.
+ const (return [])
-- | Generate and write to disk all built-in autogenerated files
-- for the specified component. These files will be put in the
@@ -1190,7 +1223,7 @@ builtinAutogenFiles pkg lbi clbi =
pathsFile = AutogenModule (autogenPathsModuleName pkg) (Suffix "hs")
pathsContents = toUTF8LBS $ generatePathsModule pkg lbi clbi
packageInfoFile = AutogenModule (autogenPackageInfoModuleName pkg) (Suffix "hs")
- packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg lbi
+ packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg
cppHeaderFile = AutogenFile $ toShortText cppHeaderName
cppHeaderContents = toUTF8LBS $ generateCabalMacrosHeader pkg lbi clbi
diff --git a/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs b/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs
index be5aa378796..ea576ce3227 100644
--- a/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs
+++ b/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs
@@ -19,11 +19,14 @@ 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
+ ( PackageName
+ , packageName
+ , packageVersion
+ , unPackageName
+ )
+import Distribution.Types.PackageDescription (PackageDescription (..))
+import Distribution.Types.Version (versionNumbers)
+import Distribution.Utils.ShortText (fromShortText)
import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z
@@ -33,8 +36,8 @@ import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z
-- ------------------------------------------------------------
-generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String
-generatePackageInfoModule pkg_descr lbi =
+generatePackageInfoModule :: PackageDescription -> String
+generatePackageInfoModule pkg_descr =
Z.render
Z.Z
{ Z.zPackageName = showPkgName $ packageName pkg_descr
@@ -42,15 +45,7 @@ generatePackageInfoModule pkg_descr lbi =
, 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
diff --git a/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs b/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
index 6fdbfb176b7..015c3ea3058 100644
--- a/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
+++ b/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
@@ -2,7 +2,7 @@
module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where
-import Distribution.ZinzaPrelude
+import Distribution.ZinzaPrelude (Generic, execWriter, tell)
data Z = Z
{ zPackageName :: String
@@ -10,18 +10,12 @@ data Z = Z
, 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 "{-# LANGUAGE NoRebindableSyntax #-}\n"
tell "{-# OPTIONS_GHC -w #-}\n"
tell "\n"
tell "{-|\n"
diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule.hs b/Cabal/src/Distribution/Simple/Build/PathsModule.hs
index 9392acf3cef..525c19598b8 100644
--- a/Cabal/src/Distribution/Simple/Build/PathsModule.hs
+++ b/Cabal/src/Distribution/Simple/Build/PathsModule.hs
@@ -44,8 +44,6 @@ generatePathsModule pkg_descr lbi clbi =
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
@@ -63,15 +61,6 @@ generatePathsModule pkg_descr lbi clbi =
, 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
diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs b/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
index d401ce305c4..e324c8ea11c 100644
--- a/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
+++ b/Cabal/src/Distribution/Simple/Build/PathsModule/Z.hs
@@ -5,8 +5,6 @@ import Distribution.ZinzaPrelude
data Z
= Z {zPackageName :: PackageName,
zVersionDigits :: String,
- zSupportsCpp :: Bool,
- zSupportsNoRebindableSyntax :: Bool,
zAbsolute :: Bool,
zRelocatable :: Bool,
zIsWindows :: Bool,
@@ -25,18 +23,8 @@ data Z
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 ()
+ tell "{-# LANGUAGE CPP #-}\n"
+ tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
if (zNot z_root (zAbsolute z_root))
then do
tell "{-# LANGUAGE ForeignFunctionInterface #-}\n"
@@ -91,25 +79,8 @@ render z_root = execWriter $ do
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 "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"
+ tell "catchIO = Exception.catch\n"
tell "\n"
tell "-- |The package version.\n"
tell "version :: Version\n"
diff --git a/Cabal/src/Distribution/Simple/BuildPaths.hs b/Cabal/src/Distribution/Simple/BuildPaths.hs
index 279d605f1e7..54472859339 100644
--- a/Cabal/src/Distribution/Simple/BuildPaths.hs
+++ b/Cabal/src/Distribution/Simple/BuildPaths.hs
@@ -27,6 +27,7 @@ module Distribution.Simple.BuildPaths
, haddockPref
, autogenPackageModulesDir
, autogenComponentModulesDir
+ , preBuildRulesCacheFile
, autogenPathsModuleName
, autogenPackageInfoModuleName
, cppHeaderName
@@ -160,6 +161,15 @@ autogenPackageModulesDir lbi = buildDir lbi makeRelativePathEx "global-autog
autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source)
autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi makeRelativePathEx "autogen"
+-- | The path to the pre-build rules cache file for a component, used to
+-- compute rule staleness across runs.
+preBuildRulesCacheFile
+ :: LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> SymbolicPath Pkg File
+preBuildRulesCacheFile lbi clbi =
+ componentBuildDir lbi clbi makeRelativePathEx "setup-hooks-rules.cache"
+
-- NB: Look at 'checkForeignDeps' for where a simplified version of this
-- has been copy-pasted.
diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs
index 38478a71b4c..4f66f90eea8 100644
--- a/Cabal/src/Distribution/Simple/Compiler.hs
+++ b/Cabal/src/Distribution/Simple/Compiler.hs
@@ -492,15 +492,8 @@ reexportedAsSupported comp = case compilerFlavor comp of
-- "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]
- )
+ GHC -> True
_ -> False
- where
- v = compilerVersion comp
-- | Does this compiler's "ar" command supports response file
-- arguments (i.e. @file-style arguments).
diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs
index b9ce731a33d..2ba7e22e73a 100644
--- a/Cabal/src/Distribution/Simple/Configure.hs
+++ b/Cabal/src/Distribution/Simple/Configure.hs
@@ -33,6 +33,18 @@
module Distribution.Simple.Configure
( configure
, configure_setupHooks
+ , computePackageInfo
+ , configureFinal
+ , runPreConfPackageHook
+ , runPostConfPackageHook
+ , runPreConfComponentHook
+ , configurePackage
+ , PackageInfo (..)
+ , mkProgramDb
+ , finalCheckPackage
+ , configureComponents
+ , mkPromisedDepsSet
+ , combinedConstraints
, writePersistBuildConfig
, getConfigStateFile
, getPersistBuildConfig
@@ -54,6 +66,9 @@ module Distribution.Simple.Configure
, configCompilerAuxEx
, configCompilerProgDb
, computeEffectiveProfiling
+ , adjustBuildOptions
+ , buildOptionsAdjustmentWarnings
+ , adjustBuildOptionsAndWarn
, ccLdOptionsBuildInfo
, checkForeignDeps
, interpretPackageDbFlags
@@ -80,7 +95,6 @@ import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory)
import Distribution.PackageDescription.Configuration
-import Distribution.PackageDescription.PrettyPrint
import Distribution.Simple.BuildTarget
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.BuildWay
@@ -156,7 +170,6 @@ import System.Directory
, doesFileExist
, doesPathExist
, listDirectory
- , removeFile
)
import System.FilePath
( isAbsolute
@@ -182,6 +195,7 @@ import Text.PrettyPrint
import qualified Data.Maybe as M
import qualified Data.Set as Set
import qualified Distribution.Compat.NonEmptySet as NES
+import GHC.Stack (HasCallStack)
type UseExternalInternalDeps = Bool
@@ -313,7 +327,7 @@ maybeGetPersistBuildConfig
-- ^ The @dist@ directory path.
-> IO (Maybe LocalBuildInfo)
maybeGetPersistBuildConfig mbWorkDir =
- liftM (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir
+ fmap (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir
-- | After running configure, output the 'LocalBuildInfo' to the
-- 'localBuildInfoFile'.
@@ -423,7 +437,7 @@ findDistPref
-- ^ override \"dist\" prefix
-> IO (SymbolicPath Pkg (Dir Dist))
findDistPref defDistPref overrideDistPref = do
- envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")
+ envDistPref <- parseEnvDistPref <$> lookupEnv "CABAL_BUILDDIR"
return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)
where
parseEnvDistPref env =
@@ -458,99 +472,215 @@ configure_setupHooks
-> ConfigFlags
-> IO LocalBuildInfo
configure_setupHooks
- (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook})
+ confHooks@(ConfigureHooks{preConfPackageHook})
(g_pkg_descr, hookedBuildInfo)
verbHandles
cfg = do
- -- Cabal pre-configure
- let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg))
- distPref = fromFlag $ configDistPref cfg
- mbWorkDir = flagToMaybe $ configWorkingDir cfg
(lbc0, comp, platform, enabledComps) <- preConfigurePackage verbHandles 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
- }
+ maybe
+ (return lbc0)
+ (runPreConfPackageHook cfg comp platform lbc0)
+ preConfPackageHook
-- Cabal package-wide configure
- (lbc2, pbd2, pkg_info) <-
- finalizeAndConfigurePackage
+ (allConstraints, pkgInfo) <-
+ computePackageInfo verbHandles cfg lbc1 g_pkg_descr comp
+ (packageDbs, pkg_descr0, flags) <-
+ finalizePackageDescription
verbHandles
cfg
- lbc1
g_pkg_descr
comp
platform
enabledComps
+ allConstraints
+ pkgInfo
- -- Package-wide post-configure hook
- for_ postConfPackageHook $ \postConfPkg -> do
- let input =
- SetupHooks.PostConfPackageInputs
- { SetupHooks.localBuildConfig = lbc2
- , SetupHooks.packageBuildDescr = pbd2
- }
- postConfPkg input
+ configureFinal
+ verbHandles
+ confHooks
+ hookedBuildInfo
+ cfg
+ lbc1
+ (g_pkg_descr, pkg_descr0)
+ flags
+ enabledComps
+ comp
+ platform
+ packageDbs
+ pkgInfo
- -- 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}
+configureFinal
+ :: VerbosityHandles
+ -> ConfigureHooks
+ -> HookedBuildInfo
+ -> ConfigFlags
+ -> LBC.LocalBuildConfig
+ -> (GenericPackageDescription, PackageDescription)
+ -> FlagAssignment
+ -> ComponentRequestedSpec
+ -> Compiler
+ -> Platform
+ -> PackageDBStack
+ -> PackageInfo
+ -> IO LocalBuildInfo
+configureFinal
+ verbHandles
+ (ConfigureHooks{postConfPackageHook, preConfComponentHook})
+ hookedBuildInfo
+ cfg
+ lbc0
+ (gpkgDescr, pkgDescr0)
+ flags
+ enabledComps
+ comp
+ platform
+ packageDbs
+ pkgInfo@PackageInfo
+ { installedPackageSet = installedPkgSet
+ , promisedDepsSet = promisedDeps
+ } =
+ do
+ let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg))
+ distPref = fromFlag $ configDistPref cfg
+ mbWorkDir = flagToMaybe $ configWorkingDir cfg
+
+ -- Apply compiler capability checks to the incoming build options
+ -- (idempotent).
+ lbc1 <- do
+ let opts = LBC.withBuildOptions lbc0
+ opts' <- adjustBuildOptionsAndWarn verbosity comp (LBC.withPrograms lbc0) opts
+ return lbc0{LBC.withBuildOptions = opts'}
+
+ -- Cabal package-wide configure
+ (lbc2, pbd2) <-
+ configurePackage verbHandles cfg lbc1 pkgDescr0 flags enabledComps comp platform packageDbs
+
+ -- Package-wide post-configure hook
+ for_ postConfPackageHook $ runPostConfPackageHook lbc2 pbd2
+
+ -- Per-component pre-configure hooks
+ pkgDescr <- do
+ let pkgDescr2 = LBC.localPkgDescr pbd2
+ applyComponentDiffs
+ verbosity
+ (for preConfComponentHook . runPreConfComponentHook lbc2 pbd2)
+ pkgDescr2
+ let pbd3 = pbd2{LBC.localPkgDescr = pkgDescr}
+
+ -- Cabal per-component configure
+ finalCheckPackage verbHandles gpkgDescr pbd3 hookedBuildInfo
+
+ let
+ use_external_internal_deps =
+ case enabledComps of
+ OneComponentRequestedSpec{} -> True
+ ComponentRequestedSpec{} -> False
+ -- The list of 'InstalledPackageInfo' recording the selected
+ -- dependencies on external packages.
+ --
+ -- Invariant: For any package name, there is at most one package
+ -- in externalPackageDeps which has that name.
+ --
+ -- NB: The dependency selection is global over ALL components
+ -- in the package (similar to how allConstraints and
+ -- requiredDepsMap are global over all components). In particular,
+ -- if *any* component (post-flag resolution) has an unsatisfiable
+ -- dependency, we will fail. This can sometimes be undesirable
+ -- for users, see #1786 (benchmark conflicts with executable),
+ --
+ -- In the presence of Backpack, these package dependencies are
+ -- NOT complete: they only ever include the INDEFINITE
+ -- dependencies. After we apply an instantiation, we'll get
+ -- definite references which constitute extra dependencies.
+ -- (Why not have cabal-install pass these in explicitly?
+ -- For one it's deterministic; for two, we need to associate
+ -- them with renamings which would require a far more complicated
+ -- input scheme than what we have today.)
+ externalPkgDeps <-
+ selectDependencies
+ verbosity
+ use_external_internal_deps
+ pkgInfo
+ pkgDescr
+ enabledComps
+ lbi <- configureComponents verbHandles lbc2 pbd3 installedPkgSet promisedDeps externalPkgDeps
+ writePersistBuildConfig mbWorkDir distPref lbi
- -- Cabal per-component configure
- externalPkgDeps <- finalCheckPackage verbHandles g_pkg_descr pbd3 hookedBuildInfo pkg_info
- lbi <- configureComponents verbHandles lbc2 pbd3 pkg_info externalPkgDeps
+ return lbi
+
+runPreConfPackageHook
+ :: ConfigFlags
+ -> Compiler
+ -> Platform
+ -> LBC.LocalBuildConfig
+ -> (SetupHooks.PreConfPackageInputs -> IO SetupHooks.PreConfPackageOutputs)
+ -> IO LBC.LocalBuildConfig
+runPreConfPackageHook cfg comp platform lbc0 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 a '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
+ }
- writePersistBuildConfig mbWorkDir distPref lbi
+runPostConfPackageHook
+ :: LBC.LocalBuildConfig
+ -> LBC.PackageBuildDescr
+ -> (SetupHooks.PostConfPackageInputs -> IO ())
+ -> IO ()
+runPostConfPackageHook lbc2 pbd2 postConfPkg =
+ let input =
+ SetupHooks.PostConfPackageInputs
+ { SetupHooks.localBuildConfig = lbc2
+ , SetupHooks.packageBuildDescr = pbd2
+ }
+ in postConfPkg input
- return lbi
+runPreConfComponentHook
+ :: LBC.LocalBuildConfig
+ -> LBC.PackageBuildDescr
+ -> Component
+ -> (SetupHooks.PreConfComponentInputs -> IO SetupHooks.PreConfComponentOutputs)
+ -> IO SetupHooks.ComponentDiff
+runPreConfComponentHook lbc pbd c hook = do
+ let input =
+ SetupHooks.PreConfComponentInputs
+ { SetupHooks.localBuildConfig = lbc
+ , SetupHooks.packageBuildDescr = pbd
+ , SetupHooks.component = c
+ }
+ SetupHooks.PreConfComponentOutputs
+ { SetupHooks.componentDiff = diff
+ } <-
+ hook input
+ return diff
preConfigurePackage
:: VerbosityHandles
@@ -656,60 +786,27 @@ computeLocalBuildConfig
computeLocalBuildConfig verbHandles cfg comp programDb = do
let common = configCommonFlags cfg
verbosity = mkVerbosity verbHandles (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
+ rawBuildOptions <- buildOptionsFromConfigFlags verbosity cfg comp
+ buildOptions <- adjustBuildOptionsAndWarn verbosity comp programDb rawBuildOptions
+ return $
+ LBC.LocalBuildConfig
+ { extraConfigArgs = []
+ , -- Currently configure does not
+ -- take extra args, but if it
+ -- did they would go here.
+ withPrograms = programDb
+ , withBuildOptions = buildOptions
+ }
+
+-- | Compute a default 'LBC.BuildOptions' from 'ConfigFlags', applying
+-- compiler-specific defaults but without compiler capability checks
+-- (see 'adjustBuildOptionsAndWarn' for that).
+buildOptionsFromConfigFlags
+ :: Verbosity
+ -> ConfigFlags
+ -> Compiler
+ -> IO LBC.BuildOptions
+buildOptionsFromConfigFlags verbosity cfg comp = do
let ghciLibByDefault =
case compilerId comp of
CompilerId GHC _ ->
@@ -726,17 +823,6 @@ computeLocalBuildConfig verbHandles cfg comp programDb = do
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
@@ -793,68 +879,174 @@ computeLocalBuildConfig verbHandles cfg comp programDb = do
strip_lib <- strip_libexe "library" configStripLibs
strip_exe <- strip_libexe "executable" configStripExes
- checkedWithBytecodeLib <-
- if bytecodeArtifactsSupported comp
- then return withBytecodeLib_
- else do
- when withBytecodeLib_ $
- warn verbosity "This compiler does not support bytecode libraries; ignoring --enable-library-bytecode"
- return False
-
- let buildOptions =
- setCoverage . setProfiling $
- LBC.BuildOptions
- { withVanillaLib = fromFlag $ configVanillaLib cfg
- , withSharedLib = withSharedLib_
- , withStaticLib = withStaticLib_
- , withBytecodeLib = checkedWithBytecodeLib
- , 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
- }
+ return $
+ setCoverage . setProfiling $
+ LBC.BuildOptions
+ { withVanillaLib = fromFlag $ configVanillaLib cfg
+ , withSharedLib = withSharedLib_
+ , withStaticLib = withStaticLib_
+ , withBytecodeLib = withBytecodeLib_
+ , withDynExe = withDynExe_
+ , withFullyStaticExe = withFullyStaticExe_
+ , withProfLib = False
+ , withProfLibShared = False
+ , withProfLibDetail = ProfDetailNone
+ , withProfExe = False
+ , withProfExeDetail = ProfDetailNone
+ , withOptimization = fromFlag $ configOptimization cfg
+ , withDebugInfo = fromFlag $ configDebugInfo cfg
+ , withGHCiLib = fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg)
+ , splitSections = fromFlagOrDefault False $ configSplitSections cfg
+ , splitObjs = fromFlagOrDefault False $ configSplitObjs cfg
+ , 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."
+-- | Adjust 'LBC.BuildOptions' to be compatible with the given 'Compiler' and
+-- 'ProgramDb'.
+--
+-- See also 'adjustBuildOptionsAndWarn', which additionally informs the user
+-- of unavailable requested features via warning messages.
+adjustBuildOptions :: Compiler -> ProgramDb -> LBC.BuildOptions -> LBC.BuildOptions
+adjustBuildOptions comp programDb opts =
+ opts
+ { LBC.splitSections = splitSec
+ , LBC.splitObjs = splitObj
+ , LBC.withGHCiLib = ghciLib
+ , LBC.withBytecodeLib = bytecodeLib
+ , LBC.exeCoverage = exeCov
+ , LBC.libCoverage = libCov
+ }
+ where
+ splitSec
+ | not (LBC.splitSections opts) = False
+ | GHC <- compilerFlavor comp
+ , compilerVersion comp >= mkVersion [8, 0] =
+ True
+ | GHCJS <- compilerFlavor comp = True
+ | otherwise = False -- not supported by this compiler
+ splitObj
+ | not (LBC.splitObjs opts) = False
+ | splitSec = False -- mutually exclusive with split-sections
+ | GHC <- compilerFlavor comp = True
+ | GHCJS <- compilerFlavor comp = True
+ | otherwise = False -- not supported by this compiler
+ 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
+
+ ghciLib
+ | LBC.withGHCiLib opts
+ , not (fromMaybe True linkerSupportsRelocations) =
+ False
+ | otherwise = LBC.withGHCiLib opts
- -- 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."
+ bytecodeLib
+ | LBC.withBytecodeLib opts
+ , not (bytecodeArtifactsSupported comp) =
+ False
+ | otherwise = LBC.withBytecodeLib opts
+
+ exeCov
+ | LBC.exeCoverage opts, not (coverageSupported comp) = False
+ | otherwise = LBC.exeCoverage opts
+
+ libCov
+ | LBC.libCoverage opts, not (coverageSupported comp) = False
+ | otherwise = LBC.libCoverage opts
+
+-- | Warnings to emit after downgrading 'LBC.BuildOptions' when the
+-- compiler (or another toolchain program) doesn't support a requested feature.
+buildOptionsAdjustmentWarnings
+ :: Compiler
+ -> LBC.BuildOptions
+ -- ^ original options
+ -> LBC.BuildOptions
+ -- ^ adjusted options (result of 'adjustBuildOptions')
+ -> [String]
+buildOptionsAdjustmentWarnings comp opts0 opts1 =
+ [ "This compiler does not support bytecode libraries; ignoring --enable-library-bytecode"
+ | LBC.withBytecodeLib opts0
+ , not (LBC.withBytecodeLib opts1)
+ ]
+ ++ [ "this compiler does not support --enable-split-sections; ignoring"
+ | LBC.splitSections opts0
+ , not (LBC.splitSections opts1)
+ ]
+ ++ [ if LBC.splitSections opts1
+ then
+ "--enable-split-sections and --enable-split-objs are mutually "
+ ++ "exclusive; ignoring the latter"
+ else "this compiler does not support --enable-split-objs; ignoring"
+ | LBC.splitObjs opts0
+ , not (LBC.splitObjs opts1)
+ ]
+ ++ [ "--enable-library-for-ghci is not supported with the current"
+ ++ " linker; ignoring..."
+ | LBC.withGHCiLib opts0
+ , not (LBC.withGHCiLib opts1)
+ ]
+ ++ [ "The compiler "
+ ++ showCompilerId comp
+ ++ " does not support "
+ ++ "program coverage. Program coverage has been disabled."
+ | LBC.exeCoverage opts0
+ , not (LBC.exeCoverage opts1)
+ ]
+
+-- | Like 'adjustBuildOptions', but includes warnings for downgraded
+-- build options.
+adjustBuildOptionsAndWarn
+ :: Verbosity
+ -> Compiler
+ -> ProgramDb
+ -> LBC.BuildOptions
+ -> IO LBC.BuildOptions
+adjustBuildOptionsAndWarn verbosity comp programDb opts0 = do
+ let opts1 = adjustBuildOptions comp programDb opts0
+ mapM_ (warn verbosity) (buildOptionsAdjustmentWarnings comp opts0 opts1)
- return $
- LBC.LocalBuildConfig
- { extraConfigArgs = [] -- Currently configure does not
- -- take extra args, but if it
- -- did they would go here.
- , withPrograms = programDb
- , withBuildOptions = buildOptions
- }
+ -- Also warn for any inconsistencies found in BuildOptions.
+ when
+ ( LBC.withDynExe opts1
+ && not (LBC.withProfExe opts1)
+ && not (LBC.withSharedLib opts1)
+ )
+ $ 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."
+ when
+ ( LBC.withDynExe opts1
+ && LBC.withProfExe opts1
+ && not (LBC.withProfLibShared opts1)
+ )
+ $ 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 opts1
data PackageInfo = PackageInfo
{ internalPackageSet :: Set LibraryName
+ -- ^ Libraries internal to the package
, promisedDepsSet :: Map (PackageName, ComponentName) PromisedComponent
+ -- ^ Collection of components that are promised, i.e. are not installed already.
+ --
+ -- See 'PromisedDependency' for more details.
, installedPackageSet :: InstalledPackageIndex
+ -- ^ Installed packages
, requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo
+ -- ^ Packages for which we have been given specific deps to use
}
configurePackage
@@ -866,12 +1058,12 @@ configurePackage
-> ComponentRequestedSpec
-> Compiler
-> Platform
- -> ProgramDb
-> PackageDBStack
-> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr)
-configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do
+configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do
let common = configCommonFlags cfg
verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+ programDb0 = LBC.withPrograms lbc0
-- add extra include/lib dirs as specified in cfg
pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg
@@ -931,7 +1123,7 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pr
defaultInstallDirs'
use_external_internal_deps
(compilerFlavor comp)
- (fromFlag (configUserInstall cfg))
+ (fromFlagOrDefault True (configUserInstall cfg))
(hasLibs pkg_descr2)
let
installDirs =
@@ -954,22 +1146,21 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pr
, extraCoverageFor = []
}
- debug verbosity $
- "Finalized package description:\n"
- ++ showPackageDescription pkg_descr2
+ -- FIXME: Printing the package description loops indefinitely.
+ -- debug verbosity $
+ -- "Finalized package description:\n"
+ -- ++ showPackageDescription pkg_descr2
return (lbc, pbd)
-finalizeAndConfigurePackage
+computePackageInfo
:: VerbosityHandles
-> ConfigFlags
-> LBC.LocalBuildConfig
-> GenericPackageDescription
-> Compiler
- -> Platform
- -> ComponentRequestedSpec
- -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo)
-finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabled = do
+ -> IO ([PackageVersionConstraint], PackageInfo)
+computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do
let common = configCommonFlags cfg
verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
mbWorkDir = flagToMaybe $ setupWorkingDir common
@@ -979,7 +1170,7 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl
packageDbs :: PackageDBStack
packageDbs =
interpretPackageDbFlags
- (fromFlag (configUserInstall cfg))
+ (fromFlagOrDefault True (configUserInstall cfg))
(configPackageDBs cfg)
-- The InstalledPackageIndex of all installed packages
@@ -1024,13 +1215,36 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl
let
promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg)
- pkg_info =
- PackageInfo
+ return
+ ( allConstraints
+ , PackageInfo
{ internalPackageSet
, promisedDepsSet
, installedPackageSet
, requiredDepsMap
}
+ )
+
+finalizePackageDescription
+ :: VerbosityHandles
+ -> ConfigFlags
+ -> GenericPackageDescription
+ -> Compiler
+ -> Platform
+ -> ComponentRequestedSpec
+ -> [PackageVersionConstraint]
+ -> PackageInfo
+ -> IO (PackageDBStack, PackageDescription, FlagAssignment)
+finalizePackageDescription verbHandles cfg g_pkg_descr comp platform enabled allConstraints pkgInfo = do
+ let common = configCommonFlags cfg
+ verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
+
+ -- What package database(s) to use
+ let packageDbs :: PackageDBStack
+ packageDbs =
+ interpretPackageDbFlags
+ (fromFlagOrDefault True (configUserInstall cfg))
+ (configPackageDBs cfg)
-- pkg_descr: The resolved package description, that does not contain any
-- conditionals, because we have an assignment for
@@ -1053,7 +1267,7 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl
( pkg_descr0 :: PackageDescription
, flags :: FlagAssignment
) <-
- configureFinalizedPackage
+ finalizePackageDescription2
verbosity
cfg
enabled
@@ -1063,28 +1277,12 @@ finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabl
(fromFlagOrDefault False (configExactConfiguration cfg))
(fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg))
(packageName g_pkg_descr)
- installedPackageSet
- internalPackageSet
- promisedDepsSet
- requiredDepsMap
+ pkgInfo
)
comp
platform
g_pkg_descr
-
- (lbc, pbd) <-
- configurePackage
- verbHandles
- cfg
- lbc0
- pkg_descr0
- flags
- enabled
- comp
- platform
- programDb0
- packageDbs
- return (lbc, pbd, pkg_info)
+ return (packageDbs, pkg_descr0, flags)
addExtraIncludeLibDirsFromConfigFlags
:: PackageDescription -> ConfigFlags -> PackageDescription
@@ -1140,8 +1338,7 @@ finalCheckPackage
-> GenericPackageDescription
-> LBC.PackageBuildDescr
-> HookedBuildInfo
- -> PackageInfo
- -> IO ([PreExistingComponent], [ConfiguredPromisedComponent])
+ -> IO ()
finalCheckPackage
verbHandles
g_pkg_descr
@@ -1153,16 +1350,11 @@ finalCheckPackage
, componentEnabledSpec = enabled
}
)
- hookedBuildInfo
- (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) =
+ hookedBuildInfo =
do
let common = configCommonFlags cfg
verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
cabalFileDir = packageRoot common
- use_external_internal_deps =
- case enabled of
- OneComponentRequestedSpec{} -> True
- ComponentRequestedSpec{} -> False
checkCompilerProblems verbosity comp pkg_descr enabled
checkPackageProblems
@@ -1181,62 +1373,33 @@ finalCheckPackage
nub $
mapMaybe defaultLanguage (enabledBuildInfos pkg_descr enabled)
let langs = unsupportedLanguages comp langlist
- when (not (null langs)) $
+ unless (null langs) $
dieWithException verbosity $
- UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs)
+ UnsupportedLanguages (packageId 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)) $
+ unless (null exts) $
dieWithException verbosity $
- UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (map prettyShow exts)
+ UnsupportedLanguageExtension (packageId 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)) $
+ unless (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
- :: VerbosityHandles
+ :: HasCallStack
+ => VerbosityHandles
-> LBC.LocalBuildConfig
-> LBC.PackageBuildDescr
- -> PackageInfo
+ -> InstalledPackageIndex
+ -> Map (PackageName, ComponentName) PromisedComponent
-> ([PreExistingComponent], [ConfiguredPromisedComponent])
-> IO LocalBuildInfo
configureComponents
@@ -1249,7 +1412,8 @@ configureComponents
, componentEnabledSpec = enabled
}
)
- (PackageInfo{promisedDepsSet, installedPackageSet})
+ installedPackageSet
+ promisedDepsSet
externalPkgDeps =
do
let common = configCommonFlags cfg
@@ -1471,7 +1635,7 @@ checkExactConfiguration verbosity pkg_descr0 cfg =
let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg))
allFlags = map flagName . genPackageFlags $ pkg_descr0
diffFlags = allFlags \\ cmdlineFlags
- when (not . null $ diffFlags) $
+ unless (null diffFlags) $
dieWithException verbosity $
FlagsNotSpecified diffFlags
@@ -1503,23 +1667,19 @@ dependencySatisfiable
-> Bool
-- ^ allow depending on private libs?
-> PackageName
- -> InstalledPackageIndex
- -- ^ installed set
- -> Set LibraryName
- -- ^ library components
- -> Map (PackageName, ComponentName) PromisedComponent
- -> Map (PackageName, ComponentName) InstalledPackageInfo
- -- ^ required dependencies
+ -> PackageInfo
-> (Dependency -> DependencySatisfaction)
dependencySatisfiable
use_external_internal_deps
exact_config
allow_private_deps
pn
- installedPackageSet
- packageLibraries
- promisedDeps
- requiredDepsMap
+ PackageInfo
+ { internalPackageSet = packageLibraries
+ , promisedDepsSet = promisedDeps
+ , installedPackageSet
+ , requiredDepsMap
+ }
(Dependency depName vr sublibs)
| exact_config =
-- When we're given '--exact-configuration', we assume that all
@@ -1614,7 +1774,7 @@ dependencySatisfiable
-- | Finalize a generic package description.
--
-- The workhorse is 'finalizePD'.
-configureFinalizedPackage
+finalizePackageDescription2
:: Verbosity
-> ConfigFlags
-> ComponentRequestedSpec
@@ -1626,7 +1786,7 @@ configureFinalizedPackage
-> Platform
-> GenericPackageDescription
-> IO (PackageDescription, FlagAssignment)
-configureFinalizedPackage
+finalizePackageDescription2
verbosity
cfg
enabled
@@ -1682,25 +1842,17 @@ checkCompilerProblems verbosity comp pkg_descr enabled = do
$ dieWithException verbosity CompilerDoesn'tSupportBackpack
-- | Select dependencies for the package.
-configureDependencies
+selectDependencies
:: Verbosity
-> UseExternalInternalDeps
- -> Set LibraryName
- -> Map (PackageName, ComponentName) PromisedComponent
- -> InstalledPackageIndex
- -- ^ installed packages
- -> Map (PackageName, ComponentName) InstalledPackageInfo
- -- ^ required deps
+ -> PackageInfo
-> PackageDescription
-> ComponentRequestedSpec
-> IO ([PreExistingComponent], [ConfiguredPromisedComponent])
-configureDependencies
+selectDependencies
verbosity
use_external_internal_deps
- packageLibraries
- promisedDeps
- installedPackageSet
- requiredDepsMap
+ pkgInfo
pkg_descr
enableSpec = do
let failedDeps :: [FailedDependency]
@@ -1713,10 +1865,7 @@ configureDependencies
, let status =
selectDependency
(package pkg_descr)
- packageLibraries
- promisedDeps
- installedPackageSet
- requiredDepsMap
+ pkgInfo
use_external_internal_deps
dep
]
@@ -1970,15 +2119,7 @@ data DependencyResolution
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
+ -> PackageInfo
-> UseExternalInternalDeps
-- ^ Are we configuring a
-- single component?
@@ -1986,10 +2127,13 @@ selectDependency
-> [Either FailedDependency DependencyResolution]
selectDependency
pkgid
- internalIndex
- promisedIndex
- installedIndex
- requiredDepsMap
+ ( PackageInfo
+ { internalPackageSet = internalIndex
+ , promisedDepsSet = promisedIndex
+ , installedPackageSet = installedIndex
+ , requiredDepsMap
+ }
+ )
use_external_internal_deps
(Dependency dep_pkgname vr libs) =
-- If the dependency specification matches anything in the internal package
@@ -2096,7 +2240,7 @@ getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do
-- 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
+ GHC -> GHC.getInstalledPackages verbosity mbWorkDir packageDBs' progdb
GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb
UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb
flv ->
@@ -2222,7 +2366,7 @@ combinedConstraints
, Map (PackageName, ComponentName) InstalledPackageInfo
)
combinedConstraints constraints dependencies installedPackages = do
- when (not (null badComponentIds)) $
+ unless (null badComponentIds) $
Left $
CombinedConstraints (dispDependencies badComponentIds)
@@ -2608,14 +2752,10 @@ checkForeignDeps pkg lbi verbosity =
-- 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.
+ -- If it exists in both, issue a warning, because C compilers are
+ -- not guaranteed to pick the correct one and there appears to be
+ -- no way to control which is picked.
--
- -- 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"
@@ -2632,9 +2772,7 @@ checkForeignDeps pkg lbi verbosity =
++ (getSymbolicPath (buildDir lbi) hdr)
++ " and "
++ (baseDir hdr)
- ++ "; removing "
- ++ (baseDir hdr)
- removeFile (baseDir hdr)
+ ++ ". Which one the C compiler will use is unspecified."
findOffendingHdr =
ifBuildsWith
@@ -2923,12 +3061,7 @@ 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 GHC = goGhcPlatform platform
go _ =
unsupported
[ "Building foreign libraries is currently only supported with ghc"
diff --git a/Cabal/src/Distribution/Simple/Errors.hs b/Cabal/src/Distribution/Simple/Errors.hs
index f2f57fd907b..4dc21def00d 100644
--- a/Cabal/src/Distribution/Simple/Errors.hs
+++ b/Cabal/src/Distribution/Simple/Errors.hs
@@ -96,8 +96,7 @@ data CabalException
| AmbiguousBuildTarget [(String, [(String, String)])]
| CheckBuildTargets String
| VersionMismatchGHC FilePath Version FilePath Version
- | CheckPackageDbStackPost76
- | CheckPackageDbStackPre76
+ | CheckPackageDbStack
| GlobalPackageDbSpecifiedFirst
| CantInstallForeignLib
| NoSupportForPreProcessingTest TestType
@@ -230,8 +229,8 @@ exceptionCode e = case e of
AmbiguousBuildTarget{} -> 7865
CheckBuildTargets{} -> 4733
VersionMismatchGHC{} -> 4000
- CheckPackageDbStackPost76{} -> 3000
- CheckPackageDbStackPre76{} -> 5640
+ CheckPackageDbStack{} -> 3000
+ -- Retired: CheckPackageDbStackPre76{} -> 5640
GlobalPackageDbSpecifiedFirst{} -> 2345
CantInstallForeignLib{} -> 8221
NoSupportForPreProcessingTest{} -> 3008
@@ -470,13 +469,9 @@ exceptionMessage e = case e of
++ ghcPkgProgPath
++ " is version "
++ prettyShow ghcPkgVersion
- CheckPackageDbStackPost76 ->
+ CheckPackageDbStack ->
"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"
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
index c21fdef1906..af021a0c0f9 100644
--- a/Cabal/src/Distribution/Simple/GHC.hs
+++ b/Cabal/src/Distribution/Simple/GHC.hs
@@ -91,7 +91,6 @@ 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
@@ -99,6 +98,7 @@ import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..))
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
+import Distribution.Simple.Flag
import qualified Distribution.Simple.GHC.Build as GHC
import Distribution.Simple.GHC.Build.Modules (BuildWay (..))
import Distribution.Simple.GHC.Build.Utils
@@ -188,7 +188,7 @@ configureCompiler verbosity hcPath conf0 = do
-- Cabal currently supports GHC less than `maxGhcVersion`
let maxGhcVersion = mkVersion [9, 16]
unless (ghcVersion < maxGhcVersion) $
- warn verbosity $
+ info verbosity $
"Unknown/unsupported 'ghc' version detected "
++ "(Cabal "
++ prettyShow cabalVersion
@@ -200,8 +200,8 @@ configureCompiler verbosity hcPath conf0 = do
++ prettyShow ghcVersion
let implInfo = ghcVersionImplInfo ghcVersion
- languages <- Internal.getLanguages verbosity implInfo ghcProg
- extensions0 <- Internal.getExtensions verbosity implInfo ghcProg
+ languages <- Internal.getLanguages implInfo
+ extensions0 <- Internal.getExtensions verbosity ghcProg
ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg
@@ -238,12 +238,13 @@ configureCompiler verbosity hcPath conf0 = do
-- In this example, @AbiTag@ is "inplace".
compilerAbiTag :: AbiTag
compilerAbiTag =
- maybe
- NoAbiTag
- AbiTag
- ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)
- <$> projectUnitId
- )
+ case Map.lookup "Project Unit Id" ghcInfoMap of
+ Nothing -> NoAbiTag
+ Just "" -> NoAbiTag
+ Just projectUnitId ->
+ case dropWhile (== '-') $ stripCommonPrefix (prettyShow compilerId) projectUnitId of
+ "" -> NoAbiTag
+ tag -> AbiTag tag
wiredInUnitIds = do
ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap
@@ -317,14 +318,8 @@ compilerProgramDb verbosity comp progdb1 hcPkgPath = do
ghcProg = fromJust $ lookupProgram ghcProgram progdb1
ghcVersion = compilerVersion comp
- -- configure gcc, ld, ar etc... based on the paths stored
- -- in the GHC settings file
- progdb3 =
- Internal.configureToolchain
- (ghcVersionImplInfo ghcVersion)
- ghcProg
- (compilerProperties comp)
- progdb2
+ -- configure gcc, ld, ar etc... based on the paths stored in the GHC settings file
+ progdb3 <- Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb2
-- 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
@@ -489,14 +484,13 @@ getPackageDBContents verbosity mbWorkDir packagedb progdb = do
-- | 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
+getInstalledPackages verbosity mbWorkDir packagedbs progdb = do
checkPackageDbEnvVar verbosity
- checkPackageDbStack verbosity comp packagedbs
+ checkPackageDbStack verbosity packagedbs
pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb
index <- toPackageIndex verbosity pkgss progdb
return $! hackRtsPackage index
@@ -504,7 +498,7 @@ getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do
hackRtsPackage index =
case PackageIndex.lookupPackageName index (mkPackageName "rts") of
[(_, [rts])] ->
- PackageIndex.insert (removeMingwIncludeDir rts) index
+ PackageIndex.insert rts index
_ -> index -- No (or multiple) ghc rts package is registered!!
-- Feh, whatever, the ghc test suite does some crazy stuff.
@@ -576,39 +570,13 @@ 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)
+checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
+checkPackageDbStack _ (GlobalPackageDB : rest)
| GlobalPackageDB `notElem` rest = return ()
-checkPackageDbStackPost76 verbosity rest
+checkPackageDbStack 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'}
+ dieWithException verbosity CheckPackageDbStack
+checkPackageDbStack _ _ = return ()
-- | Get the packages from specific PackageDBs, not cumulative.
getInstalledPackages'
@@ -710,7 +678,7 @@ startInterpreter verbosity progdb comp platform packageDBs = do
{ ghcOptMode = toFlag GhcModeInteractive
, ghcOptPackageDBs = packageDBs
}
- checkPackageDbStack verbosity comp packageDBs
+ checkPackageDbStack verbosity 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.
@@ -940,7 +908,7 @@ installFLib verbosity lbi targetDir builtDir _pkg flib =
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
+ unless (null (foreignLibVersion flib os)) $ do
when (os /= Linux) $ dieWithException verbosity CantInstallForeignLib
#ifndef mingw32_HOST_OS
-- 'createSymbolicLink file1 file2' creates a symbolic link
@@ -1134,23 +1102,9 @@ installLib verbosity lbi targetDir dynlibTargetDir bytecodeTargetDir _builtDir p
-- -----------------------------------------------------------------------------
-- Registering
-hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
+hcPkgInfo :: ProgramDb -> HcPkg.ConfiguredProgram
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
+ fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb
registerPackage
:: Verbosity
diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs
index 32e23de4438..a1f07219e3e 100644
--- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs
+++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs
@@ -17,7 +17,6 @@ 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)
@@ -32,7 +31,6 @@ 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
@@ -51,8 +49,6 @@ import Distribution.Version
import System.Directory
( createDirectoryIfMissing
, doesDirectoryExist
- , doesFileExist
- , removeFile
, renameFile
)
import System.FilePath
@@ -219,7 +215,7 @@ linkOrLoadComponent
get_rpaths ways =
if DynWay `Set.member` ways then getRPaths pbci else return (toNubListR [])
in
- when (not $ componentIsIndefinite clbi) $ do
+ unless (componentIsIndefinite clbi) $ do
-- If not building dynamically, we don't pass any runtime paths.
liftIO $ do
info verbosity "Linking..."
@@ -230,7 +226,7 @@ linkOrLoadComponent
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
+ linkLibrary buildTargetDir cleanedExtraLibDirs verbosity runGhcProg lib lbi clbi extraSources rpaths libWays
CFLib flib -> do
let flib_way = wantedFLibWay (withDynFLib flib)
rpaths <- get_rpaths (Set.singleton flib_way)
@@ -245,8 +241,6 @@ linkLibrary
-- ^ 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
@@ -260,18 +254,13 @@ linkLibrary
-> [BuildWay]
-- ^ Wanted build ways and corresponding build options
-> IO ()
-linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do
+linkLibrary buildTargetDir cleanedExtraLibDirs 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 =
@@ -288,19 +277,6 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
makeRelativePathEx (mkBytecodeLibName 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
getObjWayFiles :: BuildWay -> IO [SymbolicPath Pkg File]
getObjWayFiles w = getObjFiles (buildWayObjectExtension objExtension w) (buildWayObjectExtension objExtension w)
@@ -320,18 +296,6 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
hs_ext
True
, pure $ map (srcObjPath obj_ext) extraSources
- , catMaybes
- <$> sequenceA
- [ findFileCwdWithExtension
- mbWorkDir
- [Suffix obj_ext]
- [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@),
@@ -399,14 +363,7 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
, 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
+ , ghcOptDylibName = mempty
, ghcOptLinkLibs = extraLibs libBi
, ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs
, ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi
@@ -425,14 +382,7 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
, 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
+ , ghcOptDylibName = mempty
, ghcOptLinkLibs = extraLibs libBi
, ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs
, ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi
@@ -545,16 +495,11 @@ linkExecutable linkerOpts (way, buildOpts) targetDir targetName runGhcProg lbi =
-- 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
@@ -661,7 +606,7 @@ getRPaths pbci = do
supportRPaths OSX = True
supportRPaths FreeBSD =
case compid of
- CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True
+ CompilerId GHC _ -> True
_ -> False
supportRPaths OpenBSD = False
supportRPaths NetBSD = False
diff --git a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs
index f575697819b..6fc9bad442e 100644
--- a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs
+++ b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs
@@ -20,7 +20,13 @@ import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Simple.Compiler
-import Distribution.Version
+ ( Compiler
+ , CompilerFlavor (..)
+ , compilerCompatVersion
+ , compilerFlavor
+ , compilerVersion
+ )
+import Distribution.Types.Version (Version, versionNumbers)
-- |
-- Information about features and quirks of a GHC-based implementation.
@@ -34,30 +40,14 @@ import Distribution.Version
-- 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
+ { 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
@@ -88,18 +78,10 @@ getImplInfo comp =
ghcVersionImplInfo :: Version -> GhcImplInfo
ghcVersionImplInfo ver =
GhcImplInfo
- { supportsHaskell2010 = v >= [7]
- , supportsGHC2021 = v >= [9, 1]
+ { 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]
@@ -115,18 +97,10 @@ ghcjsVersionImplInfo
-> GhcImplInfo
ghcjsVersionImplInfo _ghcjsver ghcver =
GhcImplInfo
- { supportsHaskell2010 = True
- , supportsGHC2021 = True
+ { supportsGHC2021 = ghcv >= [9, 1]
, supportsGHC2024 = ghcv >= [9, 9]
- , reportsNoExt = True
- , alwaysNondecIndent = False
- , flagGhciScript = True
- , flagProfAuto = True
- , flagProfLate = True
- , flagPackageConf = False
- , flagDebugInfo = False
+ , flagProfLate = ghcv >= [9, 4]
, 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]
diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs
index 51e984a141f..bb9c9e949c1 100644
--- a/Cabal/src/Distribution/Simple/GHC/Internal.hs
+++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs
@@ -100,37 +100,47 @@ targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
-- | Adjust the way we find and configure gcc and ld
configureToolchain
- :: GhcImplInfo
+ :: Verbosity
+ -> 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
+ -> IO ProgramDb
+configureToolchain verbosity _implInfo ghcProg ghcInfo db = do
+ -- this is a bit of a hack. We have a dependency of ld on gcc.
+ -- ld needs to compiler a c program, to check an ld feature.
+ -- we _could_ use ghc as a c frontend, but we do not pass all
+ -- db stack appropriately, and thus we can run into situations
+ -- where GHC will fail if it's stricter in it's wired-in-unit
+ -- selction and has the wrong db stack. However we don't need
+ -- ghc to compile a _test_ c program. So we configure `gcc`
+ -- first and then use `gcc` (the generic c compiler in cabal
+ -- terminology) to compile the test program.
+ let gccProgram' = gccProgram
+ { programFindLocation = findProg gccProgramName extraGccPath
+ , programPostConf = configureGcc
}
+ let db' = flip addKnownProgram db $ gccProgram'
+ (gccProg, db'') <- requireProgram verbosity gccProgram' db'
+ return $
+ flip addKnownPrograms db'' $
+ [ gppProgram
+ { programFindLocation = findProg gppProgramName extraGppPath
+ , programPostConf = configureGpp
+ }
+ , ldProgram
+ { programFindLocation = findProg ldProgramName extraLdPath
+ , programPostConf = \v cp ->
+ -- Call any existing configuration first and then add any new configuration
+ configureLd gccProg v =<< programPostConf ldProgram v cp
+ }
+ , arProgram
+ { programFindLocation = findProg arProgramName extraArPath
+ }
+ , stripProgram
+ { programFindLocation = findProg stripProgramName extraStripPath
+ }
+ ]
where
compilerDir, base_dir, mingwBinDir :: FilePath
compilerDir = takeDirectory (programPath ghcProg)
@@ -192,10 +202,8 @@ configureToolchain _implInfo ghcProg 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"
+ gccLinkerFlags = getFlags "C compiler link flags"
+ ldLinkerFlags = 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
@@ -230,27 +238,26 @@ configureToolchain _implInfo ghcProg ghcInfo =
++ cxxFlags
}
- configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
- configureLd v ldProg = do
- ldProg' <- configureLd' v ldProg
+ configureLd :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureLd gccProg v ldProg = do
+ ldProg' <- configureLd' gccProg 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
+ configureLd' :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ configureLd' gccProg v 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"
+ v
+ gccProg
+ [ "-c"
, testcfile
, "-o"
, testofile
@@ -271,11 +278,9 @@ configureToolchain _implInfo ghcProg ghcInfo =
else return ldProg
getLanguages
- :: Verbosity
- -> GhcImplInfo
- -> ConfiguredProgram
+ :: GhcImplInfo
-> IO [(Language, String)]
-getLanguages _ implInfo _
+getLanguages implInfo
-- TODO: should be using --supported-languages rather than hard coding
| supportsGHC2024 implInfo =
return
@@ -290,12 +295,11 @@ getLanguages _ implInfo _
, (Haskell2010, "-XHaskell2010")
, (Haskell98, "-XHaskell98")
]
- | supportsHaskell2010 implInfo =
+ | otherwise =
return
[ (Haskell98, "-XHaskell98")
, (Haskell2010, "-XHaskell2010")
]
- | otherwise = return [(Haskell98, "")]
getGhcInfo
:: Verbosity
@@ -317,45 +321,18 @@ getGhcInfo verbosity _implInfo ghcProg = do
getExtensions
:: Verbosity
- -> GhcImplInfo
-> ConfiguredProgram
-> IO [(Extension, Maybe String)]
-getExtensions verbosity implInfo ghcProg = do
+getExtensions verbosity 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
+ return
+ [ (ext, Just $ "-X" ++ prettyShow ext)
+ | Just ext <- map simpleParsec $ lines str
+ ]
includePaths
:: LocalBuildInfo
diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs
index e139e2a5962..838c87cf5b2 100644
--- a/Cabal/src/Distribution/Simple/GHCJS.hs
+++ b/Cabal/src/Distribution/Simple/GHCJS.hs
@@ -97,7 +97,6 @@ import System.Directory
, createDirectoryIfMissing
, doesFileExist
, getAppUserDataDirectory
- , removeFile
, renameFile
)
import System.FilePath
@@ -154,8 +153,8 @@ configureCompiler verbosity hcPath conf0 = do
let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion
- languages <- Internal.getLanguages verbosity implInfo ghcjsProg
- extensions <- Internal.getExtensions verbosity implInfo ghcjsProg
+ languages <- Internal.getLanguages implInfo
+ extensions <- Internal.getExtensions verbosity ghcjsProg
ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
let ghcInfoMap = Map.fromList ghcjsInfo
@@ -751,23 +750,6 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
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
@@ -811,15 +793,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
, 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
+ , ghcOptHideAllPackages = toFlag True
, ghcOptNoAutoLinkPackages = toFlag True
, ghcOptPackageDBs = withPackageDB lbi
, ghcOptThisUnitId = case clbi of
@@ -1570,10 +1544,6 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- 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
@@ -1742,7 +1712,7 @@ getRPaths lbi clbi | supportRPaths hostOS = do
supportRPaths OSX = True
supportRPaths FreeBSD =
case compid of
- CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True
+ CompilerId GHC _ -> True
_ -> False
supportRPaths OpenBSD = False
supportRPaths NetBSD = False
@@ -2035,23 +2005,9 @@ findGhcjsPkgGhcjsVersion verbosity pgm =
-- -----------------------------------------------------------------------------
-- Registering
-hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
+hcPkgInfo :: ProgramDb -> HcPkg.ConfiguredProgram
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
+ fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb
registerPackage
:: Verbosity
diff --git a/Cabal/src/Distribution/Simple/Glob/Internal.hs b/Cabal/src/Distribution/Simple/Glob/Internal.hs
index 0d87a5a2ff9..37ef82f1b4d 100644
--- a/Cabal/src/Distribution/Simple/Glob/Internal.hs
+++ b/Cabal/src/Distribution/Simple/Glob/Internal.hs
@@ -31,6 +31,9 @@ data Glob
GlobDir !GlobPieces !Glob
| -- | @**/@, where @**@ denotes recursively traversing
-- all directories and matching filenames on .
+ --
+ -- Note that the @@ portion can only match on filenames, not paths,
+ -- so for example @**/foo/*.txt@ is not supported.
GlobDirRecursive !GlobPieces
| -- | A file glob.
GlobFile !GlobPieces
@@ -74,13 +77,6 @@ instance Pretty Glob where
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 '/'
@@ -91,6 +87,17 @@ instance Parsec Glob where
P.notFollowedBy (P.satisfy isGlobEscapedChar)
)
+ parsecPath :: CabalParsing m => m Glob
+ parsecPath =
+ P.choice
+ [ do
+ P.try (P.string "**" *> dirSep)
+ GlobDirRecursive <$> parsecGlob
+ , do
+ glob <- parsecGlob
+ dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
+ ]
+
parsecGlob :: CabalParsing m => m GlobPieces
parsecGlob = some parsecPiece
where
diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
index 88d0a782135..d22645d5970 100644
--- a/Cabal/src/Distribution/Simple/Haddock.hs
+++ b/Cabal/src/Distribution/Simple/Haddock.hs
@@ -55,6 +55,9 @@ import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
+import Distribution.Simple.FileMonitor.Types
+ ( MonitorFilePath
+ )
import Distribution.Simple.Flag
import Distribution.Simple.Glob (matchDirFileGlob)
import Distribution.Simple.InstallDirs
@@ -67,12 +70,9 @@ 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
+ ( PreBuildComponentInputs (..)
+ )
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
@@ -87,7 +87,6 @@ import qualified Distribution.Utils.ShortText as ShortText
import Distribution.Verbosity
import Distribution.Version
-import Control.Monad
import Data.Bool (bool)
import Data.Either (lefts, rights)
import System.Directory (doesDirectoryExist, doesFileExist)
@@ -227,16 +226,25 @@ haddock
-> [PPSuffixHandler]
-> HaddockFlags
-> IO ()
-haddock = haddock_setupHooks noBuildHooks defaultVerbosityHandles
+haddock pkg lbi suffixHandlers flags =
+ void $
+ haddock_setupHooks
+ (const $ return [])
+ defaultVerbosityHandles
+ pkg
+ lbi
+ suffixHandlers
+ flags
haddock_setupHooks
- :: BuildHooks
+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])
+ -- ^ pre-build hook
-> VerbosityHandles
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HaddockFlags
- -> IO ()
+ -> IO [MonitorFilePath]
haddock_setupHooks
_
verbHandles
@@ -248,13 +256,16 @@ haddock_setupHooks
&& not (fromFlag $ haddockExecutables haddockFlags)
&& not (fromFlag $ haddockTestSuites haddockFlags)
&& not (fromFlag $ haddockBenchmarks haddockFlags)
- && not (fromFlag $ haddockForeignLibs haddockFlags) =
- warn (mkVerbosity verbHandles $ fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $
+ && not (fromFlag $ haddockForeignLibs haddockFlags) = do
+ warn verb $
"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."
+ return []
+ where
+ verb = mkVerbosity verbHandles $ fromFlag $ haddockVerbosity haddockFlags
haddock_setupHooks
- (BuildHooks{preBuildComponentRules = mbPbcRules})
+ preBuildHook
verbHandles
pkg_descr
lbi
@@ -310,18 +321,19 @@ haddock_setupHooks
-- 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.
- verbHandles
- (warn verbosity)
- haddockTarget
- pkg_descr
- lbi
- suffixes
- (defaultHscolourFlags `mappend` haddockToHscolour flags)
+ void $
+ hscolour'
+ (const $ return [])
+ -- NB: we are not passing the user BuildHooks here,
+ -- because we are already running the pre/post build hooks
+ -- for Haddock.
+ verbHandles
+ (warn verbosity)
+ haddockTarget
+ pkg_descr
+ lbi
+ suffixes
+ (defaultHscolourFlags `mappend` haddockToHscolour flags)
targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags)
@@ -334,7 +346,7 @@ haddock_setupHooks
internalPackageDB <-
createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags)
- (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do
+ (mons, _mbIPI) <- (\f -> foldM f ([], installedPkgs lbi) targets') $ \(monsAcc, index) target -> do
curDir <- absoluteWorkingDirLBI lbi
let
component = targetComponent target
@@ -349,21 +361,11 @@ haddock_setupHooks
, 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
+ pbci = SetupHooks.PreBuildComponentInputs (BuildHaddock flags) lbi' target
-- See Note [Hi Haddock Recompilation Avoidance]
reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do
- preBuildComponent runPreBuildHooks verbosity lbi' target
+ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target
preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes
let
doExe com = case (compToExe com) of
@@ -533,7 +535,7 @@ haddock_setupHooks
benchArgs
return index
- return ipi
+ return (monsAcc ++ mons, ipi)
for_ (extraDocFiles pkg_descr) $ \fpath -> do
files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath
@@ -541,6 +543,8 @@ haddock_setupHooks
for_ files $
copyFileToCwd verbosity mbWorkDir (unDir targetDir)
+ return mons
+
-- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build
-- index and contents for documentation of multiple packages.
createHaddockIndex
@@ -1277,8 +1281,8 @@ renderPureArgs version comp platform args =
flagToMaybe (argGhcLibDir args) -- error if Nothing?
, -- https://github.com/haskell/haddock/pull/547
[ "--reexport=" ++ prettyShow r
- | r <- argReexports args
- , isVersion 2 19
+ | isVersion 2 19
+ , r <- argReexports args
]
, argTargets args
, maybe [] ((: []) . (resourcesDirFlag ++)) . flagToMaybe . argResourcesDir $ args
@@ -1471,21 +1475,31 @@ hscolour
-> [PPSuffixHandler]
-> HscolourFlags
-> IO ()
-hscolour = hscolour_setupHooks noBuildHooks defaultVerbosityHandles
+hscolour pkg lbi pps flags =
+ void $
+ hscolour_setupHooks
+ (const $ return [])
+ defaultVerbosityHandles
+ pkg
+ lbi
+ pps
+ flags
hscolour_setupHooks
- :: BuildHooks
+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])
+ -- ^ pre-build hook
-> VerbosityHandles
-> PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
- -> IO ()
-hscolour_setupHooks setupHooks verbHandles =
- hscolour' setupHooks verbHandles dieNoVerbosity ForDevelopment
+ -> IO [MonitorFilePath]
+hscolour_setupHooks preBuildHook verbHandles =
+ hscolour' preBuildHook verbHandles dieNoVerbosity ForDevelopment
hscolour'
- :: BuildHooks
+ :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath])
+ -- ^ pre-build hook
-> VerbosityHandles
-> (String -> IO ())
-- ^ Called when the 'hscolour' exe is not found.
@@ -1494,9 +1508,9 @@ hscolour'
-> LocalBuildInfo
-> [PPSuffixHandler]
-> HscolourFlags
- -> IO ()
+ -> IO [MonitorFilePath]
hscolour'
- (BuildHooks{preBuildComponentRules = mbPbcRules})
+ preBuildHook
verbHandles
onNoHsColour
haddockTarget
@@ -1504,13 +1518,16 @@ hscolour'
lbi
suffixes
flags =
- either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg)
+ either noHsColourPath (\(hscolourProg, _, _) -> go hscolourProg)
=<< lookupProgramVersion
verbosity
hscolourProgram
(orLaterVersion (mkVersion [1, 8]))
(withPrograms lbi)
where
+ noHsColourPath excep = do
+ onNoHsColour $ exceptionMessage excep
+ return []
common = hscolourCommonFlags flags
verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common)
distPref = fromFlag $ setupDistPref common
@@ -1519,7 +1536,7 @@ hscolour'
u :: SymbolicPath Pkg to -> FilePath
u = interpretSymbolicPathCWD
- go :: ConfiguredProgram -> IO ()
+ go :: ConfiguredProgram -> IO [MonitorFilePath]
go hscolourProg = do
warn verbosity $
"the 'cabal hscolour' command is deprecated in favour of 'cabal "
@@ -1531,23 +1548,22 @@ hscolour'
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
+ let targets = allTargetsInBuildOrder' pkg_descr lbi
+
+ -- 'foldM' with arguments flipped for readability
+ forFoldM acc xs f = foldM f acc xs
+
+ forFoldM [] targets $ \monsAcc target -> do
+ let
+ comp = targetComponent target
+ clbi = targetCLBI target
+ pbci = SetupHooks.PreBuildComponentInputs (BuildHscolour flags) lbi target
+
+ mons <- preBuildComponent (preBuildHook pbci) verbosity lbi target
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
+
let
- doExe com = case (compToExe com) of
+ doExe com = case compToExe com of
Just exe -> do
let outputDir =
hscolourPref haddockTarget distPref pkg_descr
@@ -1556,6 +1572,8 @@ hscolour'
Nothing -> do
warn verbosity "Unsupported component, skipping..."
return ()
+
+ -- Execute the component-specific hscolour actions
case comp of
CLib lib -> do
let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src"
@@ -1572,6 +1590,8 @@ hscolour'
CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp
CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp
+ return (monsAcc <> mons)
+
stylesheet = flagToMaybe (hscolourCSS flags)
runHsColour
diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs
index f5cfd32c03a..162c4469d84 100644
--- a/Cabal/src/Distribution/Simple/Install.hs
+++ b/Cabal/src/Distribution/Simple/Install.hs
@@ -288,7 +288,7 @@ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do
++ binPref
)
inPath <- isInSearchPath binPref
- when (not inPath) $
+ unless inPath $
warn
verbosity
( "The directory "
diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs
index 6945dd58ae9..75ea5893c69 100644
--- a/Cabal/src/Distribution/Simple/PreProcess.hs
+++ b/Cabal/src/Distribution/Simple/PreProcess.hs
@@ -290,63 +290,65 @@ preprocessFile
-- ^ 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)
+ bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (searchLoc ++ [buildAsSrcLoc]) baseFile
+ case bsrcFiles of
+ -- found a non-processable file in one of the source dirs
+ Just _ -> do
+ pure ()
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")
+ -- 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 ->
+ when failOnMissing $ do
+ dieWithException verbosity $
+ CantFindSourceForPreProcessFile $
+ "can't find source for "
+ ++ getSymbolicPath baseFile
+ ++ " in "
+ ++ intercalate ", " (map getSymbolicPath searchLoc)
+ 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)
@@ -794,7 +796,7 @@ platformDefines lbi =
Android -> ["android"]
Ghcjs -> ["ghcjs"]
Wasi -> ["wasi"]
- Hurd -> ["hurd"]
+ Hurd -> ["gnu"]
Haiku -> ["haiku"]
OtherOS _ -> []
archStr = case hostArch of
diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs
index 7934d3be6b5..89379e3ab44 100644
--- a/Cabal/src/Distribution/Simple/Program/Builtin.hs
+++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs
@@ -105,20 +105,7 @@ ghcProgram =
}
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])
+ let ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog}
canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4]
@@ -130,11 +117,7 @@ ghcProgram =
( \v ->
-- By default, ignore GHC_ENVIRONMENT variable of any package environment
-- 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
+ applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv ghcProg
)
(programVersion ghcProg)
diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs
index c76b38e9923..be1c3ccebfb 100644
--- a/Cabal/src/Distribution/Simple/Program/Db.hs
+++ b/Cabal/src/Distribution/Simple/Program/Db.hs
@@ -67,6 +67,8 @@ module Distribution.Simple.Program.Db
, ConfiguredProgs
, updateUnconfiguredProgs
, updateConfiguredProgs
+ , updatePathProgDb
+ , programDbSignature
) where
import Distribution.Compat.Prelude
@@ -483,6 +485,45 @@ reconfigurePrograms verbosity paths argss progdb = do
where
progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths]
+-- | Update the PATH and environment variables of already-configured programs
+-- in the program database.
+--
+-- This is a somewhat sketchy operation, but it handles the following situation:
+--
+-- - we add a build-tool-depends executable to the program database, with its
+-- associated data directory environment variables;
+-- - we want invocations of GHC (an already configured program) to be able to
+-- find this program (e.g. if the build-tool-depends executable is used
+-- in a Template Haskell splice).
+--
+-- In this case, we want to add the build tool to the PATH of GHC, even though
+-- GHC is already configured which in theory means we shouldn't touch it any
+-- more.
+updatePathProgDb :: Verbosity -> ProgramDb -> IO ProgramDb
+updatePathProgDb verbosity progdb =
+ updatePathProgs verbosity progs progdb
+ where
+ progs = Map.elems $ configuredProgs progdb
+
+-- | See 'updatePathProgDb'
+updatePathProgs :: Verbosity -> [ConfiguredProgram] -> ProgramDb -> IO ProgramDb
+updatePathProgs verbosity progs progdb =
+ foldM (flip (updatePathProg verbosity)) progdb progs
+
+-- | See 'updatePathProgDb'.
+updatePathProg :: Verbosity -> ConfiguredProgram -> ProgramDb -> IO ProgramDb
+updatePathProg _verbosity prog progdb = do
+ newPath <- programSearchPathAsPATHVar (progSearchPath progdb)
+ let envOverrides = progOverrideEnv progdb
+ progOverrides = programOverrideEnv prog
+ prog' =
+ prog
+ { programOverrideEnv =
+ [("PATH", Just newPath)]
+ ++ filter ((/= "PATH") . fst) (envOverrides ++ progOverrides)
+ }
+ return $ updateProgram prog' progdb
+
-- | Check that a program is configured and available to be run.
--
-- It raises an exception if the program could not be configured, otherwise
@@ -564,3 +605,17 @@ requireProgramVersion verbosity prog range programDb =
join $
either (dieWithException verbosity) return
`fmap` lookupProgramVersion verbosity prog range programDb
+
+-- | Select the bits of a 'ProgramDb' to monitor for value changes.
+-- Use 'programsMonitorFiles' for the files to monitor.
+programDbSignature :: ProgramDb -> [ConfiguredProgram]
+programDbSignature progdb =
+ [ prog
+ { programMonitorFiles = []
+ , programOverrideEnv =
+ filter
+ ((/= "PATH") . fst)
+ (programOverrideEnv prog)
+ }
+ | prog <- configuredPrograms progdb
+ ]
diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs
index ba50f1a81f7..d68ae7af414 100644
--- a/Cabal/src/Distribution/Simple/Program/GHC.hs
+++ b/Cabal/src/Distribution/Simple/Program/GHC.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@@ -796,18 +797,12 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
| not (flagBool ghcOptProfilingMode) ->
[]
Nothing -> []
- Just GhcProfAutoAll
- | flagProfAuto implInfo -> ["-fprof-auto"]
- | otherwise -> ["-auto-all"] -- not the same, but close
+ Just GhcProfAutoAll -> ["-fprof-auto"]
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"]
+ Just GhcProfAutoToplevel -> ["-fprof-auto-top"]
+ Just GhcProfAutoExported -> ["-fprof-auto-exported"]
, ["-split-sections" | flagBool ghcOptSplitSections]
, case compilerCompatVersion GHC comp of
-- the -split-objs flag was removed in GHC 9.8
@@ -852,7 +847,7 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
, concat [["-odir", u dir] | dir <- flag ghcOptObjDir]
, concat [["-hidir", u dir] | dir <- flag ghcOptHiDir]
, concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir]
- , concat [["-gbcdir", u dir] | dir <- flag ghcOptBytecodeDir, bytecodeArtifactsSupported comp]
+ , concat [["-gbcdir", u dir] | bytecodeArtifactsSupported comp, dir <- flag ghcOptBytecodeDir]
, concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir]
, -----------------------
-- Source search path
@@ -938,7 +933,7 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
, ["-hide-all-packages" | flagBool ghcOptHideAllPackages]
, ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules]
, ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages]
- , packageDbArgs implInfo (interpretPackageDBStack Nothing (ghcOptPackageDBs opts))
+ , packageDbArgsDb (interpretPackageDBStack Nothing (ghcOptPackageDBs opts))
, concat $
let space "" = ""
space xs = ' ' : xs
@@ -948,9 +943,7 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
, ----------------------------
-- Language and extensions
- if supportsHaskell2010 implInfo
- then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage]
- else []
+ ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage]
, [ ext'
| ext <- flags ghcOptExtensions
, ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of
@@ -966,7 +959,7 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
-- GHCi
concat
- [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo
+ [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts
]
, ---------------
-- Inputs
@@ -1001,27 +994,9 @@ verbosityOpts verbosity
| 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
+packageDbArgsDb = \case
(GlobalPackageDB : UserPackageDB : dbs)
| all isSpecific dbs -> concatMap single dbs
(GlobalPackageDB : dbs)
@@ -1038,11 +1013,6 @@ packageDbArgsDb dbstack = case dbstack of
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])
diff --git a/Cabal/src/Distribution/Simple/Program/HcPkg.hs b/Cabal/src/Distribution/Simple/Program/HcPkg.hs
index ad635f362e7..df37425b4d8 100644
--- a/Cabal/src/Distribution/Simple/Program/HcPkg.hs
+++ b/Cabal/src/Distribution/Simple/Program/HcPkg.hs
@@ -14,7 +14,7 @@
-- Currently only GHC and GHCJS have hc-pkg programs.
module Distribution.Simple.Program.HcPkg
( -- * Types
- HcPkgInfo (..)
+ ConfiguredProgram (..)
, RegisterOptions (..)
, defaultRegisterOptions
@@ -45,19 +45,44 @@ module Distribution.Simple.Program.HcPkg
import Distribution.Compat.Prelude hiding (init)
import Prelude ()
-import Distribution.InstalledPackageInfo
-import Distribution.Parsec
-import Distribution.Pretty
+import Distribution.InstalledPackageInfo (InstalledPackageInfo (..), parseInstalledPackageInfo, showInstalledPackageInfo)
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty (prettyShow)
import Distribution.Simple.Compiler
-import Distribution.Simple.Errors
+ ( PackageDB
+ , PackageDBS
+ , PackageDBStack
+ , PackageDBStackS
+ , PackageDBX (..)
+ , registrationPackageDB
+ )
+import Distribution.Simple.Errors (CabalException (..))
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
+ ( IOEncoding (..)
+ , ProgramInvocation (..)
+ , getProgramInvocationLBS
+ , getProgramInvocationOutput
+ , programInvocation
+ , programInvocationCwd
+ , runProgramInvocation
+ )
+import Distribution.Simple.Program.Types (ConfiguredProgram (..))
+import Distribution.Simple.Utils (IOData (..), dieWithException, writeUTF8File)
+import Distribution.Types.ComponentId (mkComponentId)
+import Distribution.Types.PackageId (PackageId)
+import Distribution.Types.UnitId (mkLegacyUnitId, unUnitId)
import Distribution.Utils.Path
-import Distribution.Verbosity
+ ( CWD
+ , FileLike ((<.>))
+ , FileOrDir (Dir)
+ , PathLike (())
+ , Pkg
+ , PkgDB
+ , SymbolicPath
+ , interpretSymbolicPath
+ , interpretSymbolicPathCWD
+ )
+import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel)
import Data.List (stripPrefix)
import System.FilePath as FilePath
@@ -72,53 +97,27 @@ 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)
+init :: ConfiguredProgram -> Verbosity -> FilePath -> IO ()
+init hpi verbosity path =
+ runProgramInvocation verbosity (initInvocation hpi verbosity path)
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invoke
- :: HcPkgInfo
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDBStack
-> [String]
-> IO ()
-invoke hpi verbosity mbWorkDir dbStack extraArgs =
+invoke ghcProg verbosity mbWorkDir dbStack extraArgs =
runProgramInvocation verbosity invocation
where
- args = packageDbStackOpts hpi dbStack ++ extraArgs
- invocation = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args
+ args = packageDbStackOpts dbStack ++ extraArgs
+ invocation = programInvocationCwd mbWorkDir ghcProg args
-- | Additional variations in the behaviour for 'register'.
data RegisterOptions = RegisterOptions
@@ -126,9 +125,7 @@ data RegisterOptions = RegisterOptions
-- ^ 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'.
+ -- single version of a single package.
, registerSuppressFilesCheck :: Bool
-- ^ Require that no checks are performed on the existence of package
-- files mentioned in the registration info. This must be used if
@@ -149,7 +146,7 @@ defaultRegisterOptions =
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
register
- :: HcPkgInfo
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBStackS from
@@ -157,26 +154,10 @@ register
-> 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 =
+ | registerMultiInstance registerOptions =
do
let pkgdb = registrationPackageDB packagedbs
- writeRegistrationFileDirectly verbosity hpi mbWorkDir pkgdb pkgInfo
+ writeRegistrationFileDirectly verbosity mbWorkDir pkgdb pkgInfo
recache hpi verbosity mbWorkDir pkgdb
| otherwise =
runProgramInvocation
@@ -185,27 +166,24 @@ register 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
+writeRegistrationFileDirectly verbosity mbWorkDir package pkgInfo =
+ case package of
+ (SpecificPackageDB dir) -> do
+ let pkgfile = interpretSymbolicPath mbWorkDir dir prettyShow (installedUnitId pkgInfo) <.> "conf"
+ writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)
+ _ -> do
+ -- 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 :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity mbWorkDir packagedb pkgid =
runProgramInvocation
verbosity
@@ -214,7 +192,7 @@ unregister 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 :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO ()
recache hpi verbosity mbWorkDir packagedb =
runProgramInvocation
verbosity
@@ -224,7 +202,7 @@ recache hpi verbosity mbWorkDir packagedb =
--
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
expose
- :: HcPkgInfo
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDB
@@ -239,28 +217,28 @@ expose hpi verbosity mbWorkDir packagedb pkgid =
--
-- > hc-pkg describe [pkgid] [--user | --global | --package-db]
describe
- :: HcPkgInfo
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDBStack
-> PackageId
-> IO [InstalledPackageInfo]
-describe hpi verbosity mbWorkDir packagedb pid = do
+describe ghcProg verbosity mbWorkDir packagedb pid = do
output <-
getProgramInvocationLBS
verbosity
- (describeInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pid)
+ (describeInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb pid)
`catchIO` \_ -> return mempty
case parsePackages output of
Left ok -> return ok
- _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid
+ _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId ghcProg) pid
-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
hide
- :: HcPkgInfo
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDB
@@ -274,22 +252,22 @@ hide hpi verbosity mbWorkDir packagedb pkgid =
-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
dump
- :: HcPkgInfo
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBX (SymbolicPath from (Dir PkgDB))
-> IO [InstalledPackageInfo]
-dump hpi verbosity mbWorkDir packagedb = do
+dump ghcProg verbosity mbWorkDir packagedb = do
output <-
getProgramInvocationLBS
verbosity
- (dumpInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb)
+ (dumpInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb)
`catchIO` \e ->
- dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e)
+ dieWithException verbosity $ DumpFailed (programId ghcProg) (displayException e)
case parsePackages output of
Left ok -> return ok
- _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi))
+ _ -> dieWithException verbosity $ FailedToParseOutputDump (programId ghcProg)
parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String]
parsePackages lbs0 =
@@ -388,21 +366,21 @@ setUnitId pkginfo = pkginfo
-- 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
+ :: ConfiguredProgram
-> Verbosity
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDB
-> IO [PackageId]
-list hpi verbosity mbWorkDir packagedb = do
+list ghcProg verbosity mbWorkDir packagedb = do
output <-
getProgramInvocationOutput
verbosity
- (listInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb)
- `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi))
+ (listInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb)
+ `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId ghcProg)
case parsePackageIds output of
Just ok -> return ok
- _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi))
+ _ -> dieWithException verbosity $ FailedToParseOutputList (programId ghcProg)
where
parsePackageIds = traverse simpleParsec . words
@@ -410,24 +388,24 @@ list hpi verbosity mbWorkDir packagedb = do
-- The program invocations
--
-initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
-initInvocation hpi verbosity path =
- programInvocation (hcPkgProgram hpi) args
+initInvocation :: ConfiguredProgram -> Verbosity -> FilePath -> ProgramInvocation
+initInvocation ghcProg verbosity path =
+ programInvocation ghcProg args
where
args =
["init", path]
- ++ verbosityOpts hpi (verbosityLevel verbosity)
+ ++ verbosityOpts (verbosityLevel verbosity)
registerInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
-registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions =
- (programInvocationCwd mbWorkDir (hcPkgProgram hpi) (args "-"))
+registerInvocation ghcProg verbosity mbWorkDir packagedbs pkgInfo registerOptions =
+ (programInvocationCwd mbWorkDir ghcProg (args "-"))
{ progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo
, progInvokeInputEncoding = IOEncodingUTF8
}
@@ -439,146 +417,135 @@ registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions =
args file =
[cmdname, file]
- ++ packageDbStackOpts hpi packagedbs
+ ++ packageDbStackOpts packagedbs
++ [ "--enable-multi-instance"
| registerMultiInstance registerOptions
]
++ [ "--force-files"
| registerSuppressFilesCheck registerOptions
]
- ++ verbosityOpts hpi verbosity
+ ++ verbosityOpts verbosity
unregisterInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> 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
+unregisterInvocation ghcProg verbosity mbWorkDir packagedb pkgid =
+ programInvocationCwd mbWorkDir ghcProg $
+ ["unregister", packageDbOpts packagedb, prettyShow pkgid]
+ ++ verbosityOpts verbosity
recacheInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBS from
-> ProgramInvocation
-recacheInvocation hpi verbosity mbWorkDir packagedb =
- programInvocationCwd mbWorkDir (hcPkgProgram hpi) $
- ["recache", packageDbOpts hpi packagedb]
- ++ verbosityOpts hpi verbosity
+recacheInvocation ghcProg verbosity mbWorkDir packagedb =
+ programInvocationCwd mbWorkDir ghcProg $
+ ["recache", packageDbOpts packagedb]
+ ++ verbosityOpts verbosity
exposeInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> 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
+exposeInvocation ghcProg verbosity mbWorkDir packagedb pkgid =
+ programInvocationCwd mbWorkDir ghcProg $
+ ["expose", packageDbOpts packagedb, prettyShow pkgid]
+ ++ verbosityOpts verbosity
describeInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDBStack
-> PackageId
-> ProgramInvocation
-describeInvocation hpi verbosity mbWorkDir packagedbs pkgid =
- programInvocationCwd mbWorkDir (hcPkgProgram hpi) $
+describeInvocation ghcProg verbosity mbWorkDir packagedbs pkgid =
+ programInvocationCwd mbWorkDir ghcProg $
["describe", prettyShow pkgid]
- ++ packageDbStackOpts hpi packagedbs
- ++ verbosityOpts hpi verbosity
+ ++ packageDbStackOpts packagedbs
+ ++ verbosityOpts verbosity
hideInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> 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
+hideInvocation ghcProg verbosity mbWorkDir packagedb pkgid =
+ programInvocationCwd mbWorkDir ghcProg $
+ ["hide", packageDbOpts packagedb, prettyShow pkgid]
+ ++ verbosityOpts verbosity
dumpInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD (Dir from))
-> PackageDBX (SymbolicPath from (Dir PkgDB))
-> ProgramInvocation
-dumpInvocation hpi _verbosity mbWorkDir packagedb =
- (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args)
+dumpInvocation ghcProg _verbosity mbWorkDir packagedb =
+ (programInvocationCwd mbWorkDir ghcProg args)
{ progInvokeOutputEncoding = IOEncodingUTF8
}
where
args =
- ["dump", packageDbOpts hpi packagedb]
- ++ verbosityOpts hpi Silent
+ ["dump", packageDbOpts packagedb]
+ ++ verbosityOpts Silent
-- We use verbosity level 'Silent' because it is important that we
-- do not contaminate the output with info/debug messages.
listInvocation
- :: HcPkgInfo
+ :: ConfiguredProgram
-> VerbosityLevel
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> PackageDB
-> ProgramInvocation
-listInvocation hpi _verbosity mbWorkDir packagedb =
- (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args)
+listInvocation ghcProg _verbosity mbWorkDir packagedb =
+ (programInvocationCwd mbWorkDir ghcProg args)
{ progInvokeOutputEncoding = IOEncodingUTF8
}
where
args =
- ["list", "--simple-output", packageDbOpts hpi packagedb]
- ++ verbosityOpts hpi Silent
+ ["list", "--simple-output", packageDbOpts packagedb]
+ ++ verbosityOpts 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
+packageDbStackOpts :: PackageDBStackS from -> [String]
+packageDbStackOpts dbstack = case dbstack of
+ (GlobalPackageDB : UserPackageDB : dbs) ->
+ "--global"
+ : "--user"
+ : map specific dbs
+ (GlobalPackageDB : dbs) ->
+ "--global"
+ : "--no-user-package-db"
+ : map specific dbs
+ _ -> ierror
where
- specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db
+ specific (SpecificPackageDB db) = "--package-db=" ++ 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
+packageDbOpts :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String
+packageDbOpts GlobalPackageDB = "--global"
+packageDbOpts UserPackageDB = "--user"
+packageDbOpts (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db
-verbosityOpts :: HcPkgInfo -> VerbosityLevel -> [String]
-verbosityOpts hpi v
- | noVerboseFlag hpi =
- []
+verbosityOpts :: VerbosityLevel -> [String]
+verbosityOpts v
| v >= Deafening = ["-v2"]
| v == Silent = ["-v0"]
| otherwise = []
diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs
index 35aa64687a2..c1e92a8b959 100644
--- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs
+++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs
@@ -19,7 +19,7 @@ import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding)
import Prelude ()
import Distribution.Compat.Prelude
-import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx)
+import Distribution.Simple.Utils (TempFileOptions, withTempFileEx)
import Distribution.Utils.Path
import Distribution.Verbosity
@@ -34,7 +34,7 @@ withResponseFile
-- ^ Arguments to put into response file.
-> (FilePath -> IO a)
-> IO a
-withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =
+withResponseFile _verbosity tmpFileOpts fileNameTemplate encoding arguments f =
withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do
let responseFileName = getSymbolicPath responsePath
traverse_ (hSetEncoding hf) encoding
@@ -43,9 +43,6 @@ withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =
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
diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs
index 61ac50f1ff9..3e603a14d6a 100644
--- a/Cabal/src/Distribution/Simple/Register.hs
+++ b/Cabal/src/Distribution/Simple/Register.hs
@@ -183,7 +183,7 @@ registerAll
-> IO ()
registerAll verbHandles pkg lbi regFlags ipis =
do
- when (fromFlag (regPrintId regFlags)) $ do
+ when (Just True == flagToMaybe (regPrintId regFlags)) $ do
for_ ipis $ \installedPkgInfo ->
-- Only print the public library's IPI
when
@@ -370,20 +370,19 @@ relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =
initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO ()
initPackageDB verbosity comp progdb dbPath =
- createPackageDB verbosity comp progdb False dbPath
+ createPackageDB verbosity comp progdb dbPath
-- | Create an empty package DB at the specified location.
createPackageDB
:: Verbosity
-> Compiler
-> ProgramDb
- -> Bool
-> FilePath
-> IO ()
-createPackageDB verbosity comp progdb preferCompat dbPath =
+createPackageDB verbosity comp progdb dbPath =
case compilerFlavor comp of
- GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath
- GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath
+ GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity dbPath
+ GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity dbPath
UHC -> return ()
_ -> dieWithException verbosity CreatePackageDB
@@ -423,7 +422,7 @@ withHcPkg
-> String
-> Compiler
-> ProgramDb
- -> (HcPkg.HcPkgInfo -> IO a)
+ -> (HcPkg.ConfiguredProgram -> IO a)
-> IO a
withHcPkg verbosity name comp progdb f =
case compilerFlavor comp of
@@ -455,7 +454,7 @@ writeHcPkgRegisterScript
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> [InstalledPackageInfo]
-> PackageDBStack
- -> HcPkg.HcPkgInfo
+ -> HcPkg.ConfiguredProgram
-> IO ()
writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do
let genScript installedPkgInfo =
@@ -527,7 +526,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
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)
+ ++ map (`IPI.ExposedModule` Nothing) (virtualModules bi)
, IPI.hiddenModules = otherModules bi
, IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo
, IPI.importDirs = [libdir installDirs | hasModules]
diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs
index dce0d3f4c55..2daf040d894 100644
--- a/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs
+++ b/Cabal/src/Distribution/Simple/SetupHooks/Errors.hs
@@ -28,9 +28,6 @@ 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
@@ -129,7 +126,7 @@ rulesExceptionMessage = \case
showCycle (r, rs) =
unlines . map (" " ++) . lines $
Tree.drawTree $
- fmap showRule $
+ fmap show $
Tree.Node r rs
CantFindSourceForRuleDependencies _r deps ->
unlines $
@@ -172,22 +169,9 @@ rulesExceptionMessage = \case
DuplicateRuleId rId r1 r2 ->
unlines
[ "Duplicate pre-build rule (" <> show rId <> ")"
- , " - " <> showRule (ruleBinary r1)
- , " - " <> showRule (ruleBinary r2)
+ , " - " <> show (ruleBinary r1)
+ , " - " <> show (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
diff --git a/Cabal/src/Distribution/Simple/SetupHooks/HooksMain.hs b/Cabal/src/Distribution/Simple/SetupHooks/HooksMain.hs
new file mode 100644
index 00000000000..bdadb722a3c
--- /dev/null
+++ b/Cabal/src/Distribution/Simple/SetupHooks/HooksMain.hs
@@ -0,0 +1,407 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Implementation of hooks executables for @build-type: Hooks@ packages.
+--
+-- A hooks executable is a small program compiled from the @SetupHooks.hs@
+-- module of a package with @build-type: Hooks@. Its @main@ function is:
+--
+-- > import Distribution.Simple.SetupHooks.HooksMain (hooksMain)
+-- > import SetupHooks (setupHooks)
+-- > main = hooksMain setupHooks
+--
+-- @cabal-install@ communicates with the external hooks executable to implement
+-- the hooks in a package with @build-type: Hooks@.
+module Distribution.Simple.SetupHooks.HooksMain
+ ( -- * Main entry point for hooks executables
+ hooksMain
+
+ -- * Hooks version handshake
+ , HooksVersion (..)
+ , hooksVersion
+ , CabalABI (..)
+ , HooksABI (..)
+ ) where
+
+-- base
+import Control.Monad
+ ( (>=>)
+ )
+import Control.Monad.IO.Class
+ ( liftIO
+ )
+import GHC.Exception
+import System.Environment
+ ( getArgs
+ )
+import System.IO
+ ( Handle
+ , hClose
+ , hFlush
+ )
+
+-- bytestring
+import Data.ByteString.Lazy as LBS
+ ( ByteString
+ , hGetContents
+ , hPutStr
+ , null
+ )
+
+-- containers
+import qualified Data.Map as Map
+
+-- process
+import System.Process.CommunicationHandle
+ ( openCommunicationHandleRead
+ , openCommunicationHandleWrite
+ )
+
+-- transformers
+import Control.Monad.Trans.Except
+ ( ExceptT
+ , runExceptT
+ , throwE
+ )
+
+-- Cabal-syntax
+import qualified Distribution.Compat.Binary as Binary
+ ( decodeOrFail
+ , encode
+ )
+import Distribution.Types.Version
+ ( Version
+ )
+import Distribution.Utils.Structured
+ ( MD5
+ , structureHash
+ )
+
+-- Cabal
+import Distribution.Compat.Prelude
+import Distribution.Simple.SetupHooks.Internal
+import Distribution.Simple.SetupHooks.Rule
+import Distribution.Simple.Utils
+ ( VerboseException (..)
+ , cabalVersion
+ , dieWithException
+ , exceptionWithMetadata
+ , withOutputMarker
+ )
+import Distribution.Types.Component
+ ( componentName
+ )
+import qualified Distribution.Types.LocalBuildConfig as LBC
+import Distribution.Types.LocalBuildInfo
+ ( LocalBuildInfo
+ )
+import Distribution.Verbosity
+ ( Verbosity
+ , defaultVerbosityHandles
+ , mkVerbosity
+ )
+import qualified Distribution.Verbosity as Verbosity
+ ( normal
+ )
+
+--------------------------------------------------------------------------------
+-- Hooks version
+
+-- | The version of the Hooks API in use.
+--
+-- Used for handshake before beginning inter-process communication.
+data HooksVersion = HooksVersion
+ { hooksAPIVersion :: !Version
+ , cabalABIHash :: !MD5
+ , hooksABIHash :: !MD5
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Binary)
+
+-- | The version of the Hooks API built into this version of the Cabal library.
+--
+-- Used for handshake before beginning inter-process communication.
+hooksVersion :: HooksVersion
+hooksVersion =
+ HooksVersion
+ { hooksAPIVersion = cabalVersion
+ , cabalABIHash = structureHash $ Proxy @CabalABI
+ , hooksABIHash = structureHash $ Proxy @HooksABI
+ }
+
+-- | Tracks the parts of the Cabal API relevant to its binary interface.
+data CabalABI = CabalABI
+ { cabalLocalBuildInfo :: LocalBuildInfo
+ }
+ deriving stock (Generic)
+
+deriving anyclass instance Structured CabalABI
+
+-- | Tracks the parts of the Hooks API relevant to its binary interface.
+data HooksABI = HooksABI
+ { confHooks
+ :: ( (PreConfPackageInputs, PreConfPackageOutputs)
+ , PostConfPackageInputs
+ , (PreConfComponentInputs, PreConfComponentOutputs)
+ )
+ , buildHooks
+ :: ( PreBuildComponentInputs
+ , (RuleId, Rule, RuleBinary)
+ , PostBuildComponentInputs
+ )
+ , installHooks :: InstallComponentInputs
+ }
+ deriving stock (Generic)
+
+deriving anyclass instance Structured HooksABI
+
+--------------------------------------------------------------------------------
+-- Error types (internal)
+
+data SetupHooksExeException
+ = -- | Missing hook type argument.
+ NoHookType
+ | -- | Could not parse a communication handle argument.
+ NoHandle (Maybe String)
+ | -- | Incorrect arguments passed to the hooks executable.
+ BadHooksExeArgs
+ String
+ -- ^ hook name
+ BadHooksExecutableArgs
+ deriving (Show)
+
+-- | An error describing an invalid argument passed to a hooks executable.
+data BadHooksExecutableArgs
+ = -- | Unknown hook type was requested.
+ UnknownHookType
+ {knownHookTypes :: [String]}
+ | -- | Failed to decode the binary input to a hook.
+ CouldNotDecodeInput
+ ByteString
+ -- ^ hook input that failed to decode
+ Int64
+ -- ^ byte offset at which decoding failed
+ String
+ -- ^ decoding error message
+ | -- | The rule does not have a dynamic dependency computation.
+ NoDynDepsCmd RuleId
+ deriving (Show)
+
+setupHooksExeExceptionCode :: SetupHooksExeException -> Int
+setupHooksExeExceptionCode = \case
+ NoHookType -> 7982
+ NoHandle{} -> 8811
+ BadHooksExeArgs _ rea -> badHooksExeArgsCode rea
+
+setupHooksExeExceptionMessage :: SetupHooksExeException -> String
+setupHooksExeExceptionMessage = \case
+ NoHookType ->
+ "Missing argument to Hooks executable.\n\
+ \Expected two arguments: communication handle and hook type."
+ NoHandle Nothing ->
+ "Missing argument to Hooks executable.\n\
+ \Expected two arguments: communication handle and hook type."
+ NoHandle (Just h) ->
+ "Invalid handle reference passed to Hooks executable: '" ++ h ++ "'."
+ BadHooksExeArgs hookName reason ->
+ badHooksExeArgsMessage hookName reason
+
+badHooksExeArgsCode :: BadHooksExecutableArgs -> Int
+badHooksExeArgsCode = \case
+ UnknownHookType{} -> 4229
+ CouldNotDecodeInput{} -> 9121
+ NoDynDepsCmd{} -> 3231
+
+badHooksExeArgsMessage :: String -> BadHooksExecutableArgs -> String
+badHooksExeArgsMessage hookName = \case
+ UnknownHookType knownHookNames ->
+ "Unknown hook type "
+ ++ hookName
+ ++ ".\n\
+ \Known hook types are: "
+ ++ show knownHookNames
+ ++ "."
+ CouldNotDecodeInput _bytes offset err ->
+ "Failed to decode the input to the "
+ ++ hookName
+ ++ " hook.\n\
+ \Decoding failed at position "
+ ++ show offset
+ ++ " with error: "
+ ++ err
+ ++ ".\n\
+ \This could be due to a mismatch between the Cabal version of cabal-install\
+ \ and of the hooks executable."
+ NoDynDepsCmd rId ->
+ unlines
+ [ "Unexpected rule " <> show rId <> " in the " <> hookName <> " hook."
+ , "The rule does not have an associated dynamic dependency computation."
+ ]
+
+instance Exception (VerboseException SetupHooksExeException) where
+ displayException :: VerboseException SetupHooksExeException -> String
+ displayException (VerboseException stack timestamp verb err) =
+ withOutputMarker
+ verb
+ ( concat
+ [ "Error: [Cabal-"
+ , show (setupHooksExeExceptionCode err)
+ , "]\n"
+ ]
+ )
+ ++ exceptionWithMetadata stack timestamp verb (setupHooksExeExceptionMessage err)
+
+-- | The verbosity used inside the hooks executable.
+--
+-- The hooks executable is always invoked as a separate process, so stdout
+-- and stderr are available for verbosity output and can be redirected via
+-- the @System.Process@ API.
+hooksExeVerbosity :: Verbosity
+hooksExeVerbosity = mkVerbosity defaultVerbosityHandles Verbosity.normal
+
+--------------------------------------------------------------------------------
+-- Main entry point
+
+-- | Create a hooks executable @main@ given the package's 'SetupHooks'.
+--
+-- The executable expects three command-line arguments:
+--
+-- 1. A reference to an input communication handle (to read hook inputs from).
+-- 2. A reference to an output communication handle (to write hook outputs to).
+-- 3. The hook type to run.
+--
+-- The hook reads binary-encoded data from the input handle, runs the
+-- requested hook, and writes the binary-encoded result to the output handle.
+hooksMain :: SetupHooks -> IO ()
+hooksMain setupHooks = runHooksM $ do
+ ((hRead, hWrite), hookName) <- getHooksMainArgs
+ case lookup hookName allHookHandlers of
+ Just handleAction ->
+ handleAction (hRead, hWrite) setupHooks
+ Nothing ->
+ throwE $
+ BadHooksExeArgs hookName $
+ UnknownHookType
+ { knownHookTypes = map fst allHookHandlers
+ }
+ where
+ allHookHandlers = [(hookName h, hookHandler h) | h <- hookHandlers]
+
+ -- Get the communication handles and the name of the hook to run
+ getHooksMainArgs :: HooksM ((Handle, Handle), String)
+ getHooksMainArgs =
+ liftIO getArgs >>= \case
+ inputFdRef : outputFdRef : hookNm : _ ->
+ case (readMaybe inputFdRef, readMaybe outputFdRef) of
+ (Just readNm, Just writeNm) -> do
+ hRead <- liftIO $ openCommunicationHandleRead readNm
+ hWrite <- liftIO $ openCommunicationHandleWrite writeNm
+ return ((hRead, hWrite), hookNm)
+ (Nothing, _) ->
+ throwE $ NoHandle (Just $ "hook input communication handle '" ++ inputFdRef ++ "'")
+ (_, Nothing) ->
+ throwE $ NoHandle (Just $ "hook output communication handle '" ++ outputFdRef ++ "'")
+ _ -> throwE $ NoHandle Nothing
+
+type HooksM = ExceptT SetupHooksExeException IO
+
+runHooksM :: HooksM a -> IO a
+runHooksM = runExceptT >=> either (dieWithException hooksExeVerbosity) pure
+
+-- | Run a hook by reading its input from a handle, invoking it, and writing
+-- its output to another handle.
+runHookHandle
+ :: forall inputs outputs
+ . (Binary inputs, Binary outputs)
+ => (Handle, Handle)
+ -- ^ Input and output communication handles
+ -> String
+ -- ^ Hook name (used in error messages)
+ -> (inputs -> HooksM outputs)
+ -- ^ The hook to run
+ -> HooksM ()
+runHookHandle (hRead, hWrite) hookName hook = do
+ inputsData <- liftIO $ LBS.hGetContents hRead
+ let mb_inputs = Binary.decodeOrFail inputsData
+ case mb_inputs of
+ Left (_, offset, err) ->
+ throwE $
+ BadHooksExeArgs hookName $
+ CouldNotDecodeInput inputsData offset err
+ Right (_, _, inputs) ->
+ hook inputs >>= \output -> liftIO $ do
+ let outputData = Binary.encode output
+ unless (LBS.null outputData) $
+ LBS.hPutStr hWrite outputData
+ hFlush hWrite
+ hClose hWrite
+
+data HookHandler = HookHandler
+ { hookName :: !String
+ , hookHandler :: (Handle, Handle) -> SetupHooks -> HooksM ()
+ }
+
+hookHandlers :: [HookHandler]
+hookHandlers =
+ [ let hookName = "version"
+ in HookHandler hookName $ \h _ ->
+ runHookHandle h hookName $ \() ->
+ return hooksVersion
+ , let hookName = "preConfPackage"
+ noHook (PreConfPackageInputs{localBuildConfig = lbc}) =
+ return $
+ PreConfPackageOutputs
+ { buildOptions = LBC.withBuildOptions lbc
+ , extraConfiguredProgs = Map.empty
+ }
+ in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) ->
+ runHookHandle h hookName $ maybe noHook (liftIO .) preConfPackageHook
+ , let hookName = "postConfPackage"
+ noHook _ = return ()
+ in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) ->
+ runHookHandle h hookName $ maybe noHook (liftIO .) postConfPackageHook
+ , let hookName = "preConfComponent"
+ noHook (PreConfComponentInputs{component = c}) =
+ return $ PreConfComponentOutputs{componentDiff = emptyComponentDiff $ componentName c}
+ in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) ->
+ runHookHandle h hookName $ maybe noHook (liftIO .) preConfComponentHook
+ , let hookName = "preBuildRules"
+ in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) ->
+ runHookHandle h hookName $ \preBuildInputs ->
+ case preBuildComponentRules of
+ Nothing -> return (Map.empty, [])
+ Just pbcRules ->
+ liftIO $
+ computeRules hooksExeVerbosity preBuildInputs pbcRules
+ , let hookName = "runPreBuildRuleDeps"
+ in HookHandler hookName $ \h _ ->
+ runHookHandle h hookName $ \(ruleId, ruleDeps) ->
+ case runRuleDynDepsCmd ruleDeps of
+ Nothing ->
+ throwE $
+ BadHooksExeArgs hookName $
+ NoDynDepsCmd ruleId
+ Just getDeps -> liftIO getDeps
+ , let hookName = "runPreBuildRule"
+ in HookHandler hookName $ \h _ ->
+ runHookHandle h hookName $ \(_ruleId :: RuleId, rExecCmd) ->
+ liftIO $ runRuleExecCmd rExecCmd
+ , let hookName = "postBuildComponent"
+ noHook _ = return ()
+ in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) ->
+ runHookHandle h hookName $ maybe noHook (liftIO .) postBuildComponentHook
+ , let hookName = "installComponent"
+ noHook _ = return ()
+ in HookHandler hookName $ \h (SetupHooks{installHooks = InstallHooks{..}}) ->
+ runHookHandle h hookName $ maybe noHook (liftIO .) installComponentHook
+ ]
diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs
index 2de7ff1f622..3d767f6fdb8 100644
--- a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs
+++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs
@@ -2,9 +2,12 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
@@ -12,7 +15,8 @@
-- |
-- Module: Distribution.Simple.SetupHooks.Internal
--
--- Internal implementation module.
+-- Internal implementation module for 'SetupHooks'.
+--
-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks"
-- instead.
module Distribution.Simple.SetupHooks.Internal
@@ -77,6 +81,7 @@ module Distribution.Simple.SetupHooks.Internal
-- ** Executing build rules
, executeRules
+ , executeRulesUserOrSystem
-- ** HookedBuildInfo compatibility code
, hookedBuildInfoComponents
@@ -109,20 +114,28 @@ import qualified Distribution.Simple.SetupHooks.Rule as Rule
import Distribution.Simple.Utils
import Distribution.System (Platform (..))
import Distribution.Utils.Path
+import Distribution.Utils.Structured
+ ( structuredDecodeOrFailIO
+ , structuredEncodeFile
+ )
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 as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Coerce (coerce)
+import Data.Either (fromRight)
import qualified Data.Graph as Graph
+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
+import Data.Monoid (Ap (..))
import qualified Data.Set as Set
-import System.Directory (doesFileExist)
+import System.Directory (doesFileExist, getModificationTime)
--------------------------------------------------------------------------------
-- SetupHooks
@@ -789,8 +802,8 @@ applyComponentDiffs verbosity f = traverseComponents apply_diff
Just diff -> applyComponentDiff verbosity c diff
Nothing -> return c
-forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO ()
-forComponents_ pd f = getConst $ traverseComponents (Const . f) pd
+forComponents_ :: Applicative m => PackageDescription -> (Component -> m ()) -> m ()
+forComponents_ pd f = getAp . getConst $ traverseComponents (Const . Ap . f) pd
applyComponentDiff
:: Verbosity
@@ -849,7 +862,11 @@ executeRules =
-- an external hooks executable.
executeRulesUserOrSystem
:: forall userOrSystem
- . SScope userOrSystem
+ . ( Binary (RuleData userOrSystem)
+ , Structured (RuleData userOrSystem)
+ , Eq (RuleData userOrSystem)
+ )
+ => SScope userOrSystem
-> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString)))
-> (RuleId -> RuleExecCmd userOrSystem -> IO ())
-> Verbosity
@@ -858,6 +875,12 @@ executeRulesUserOrSystem
-> Map RuleId (RuleData userOrSystem)
-> IO ()
executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do
+ -- Load the rule cache from the previous build.
+ -- Used to detect when rule definitions have changed.
+ oldRules <- handleDoesNotExist Map.empty $ do
+ -- NB: do a strict read to avoid retaining the file handle.
+ bs <- BS.readFile rulesCacheFile
+ fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs)
-- Compute all extra dynamic dependency edges.
dynDepsEdges <-
flip Map.traverseMaybeWithKey allRules $
@@ -939,37 +962,39 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
, " it is not in the appropriate 'autogenComponentModules' directory)"
]
- -- Run all the demanded rules, in dependency order.
+ -- Run all the demanded rules, in dependency order, propagating staleness.
+ staleRulesRef <- newIORef Set.empty
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 ++ maybe [] fst mbDyn
+ let (r, rId, _staticRuleDepIds) = ruleFromVertex ruleVertex
+ Rule{ruleCommands, staticDependencies, results} = r
+ mbDynDeps = Map.lookup rId dynDepsEdges
+ allDeps = staticDependencies ++ maybe [] fst mbDynDeps
-- 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.
+ -- Dependencies OK: check whether the rule is up to date before
+ -- deciding to run it.
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 ()
+ let dynDeps = maybe [] fst mbDynDeps
+ ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps >>= \case
+ True ->
+ info verbosity $
+ "Rule " ++ show rId ++ " is up to date; skipping."
+ False -> do
+ modifyIORef' staleRulesRef (Set.insert rId)
+ runCmdData rId $ ruleExecCmd scope ruleCommands (snd <$> mbDynDeps)
+ -- 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 results
+ for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
+ errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults
+ -- Save the current rules to the cache for use in the next build.
+ structuredEncodeFile rulesCacheFile allRules
where
toRuleBinary :: RuleData userOrSystem -> RuleBinary
toRuleBinary = case scope of
@@ -978,6 +1003,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a
clbi = targetCLBI tgtInfo
mbWorkDir = mbWorkDirLBI lbi
compAutogenDir = autogenComponentModulesDir lbi clbi
+ rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi)
errorOut e =
dieWithException verbosity $
SetupHooksException $
@@ -987,6 +1013,59 @@ directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId
directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep
directRuleDependencyMaybe (FileDependency{}) = Nothing
+-- | Is the rule up to date (so that we can skip re-running it)?
+--
+-- As per the SetupHooks documentation, a rule must be re-run if:
+--
+-- - [N] the rule is new, or
+-- - [S] the rule matches with an old rule, and either:
+-- - [S1] an input to the rule has changed (either a file or rule dependency)
+-- - [S2] the rule itself has changed
+ruleUpToDate
+ :: Eq (RuleData userOrSystem)
+ => Maybe (SymbolicPath CWD (Dir Pkg))
+ -- ^ working directory
+ -> Map RuleId (RuleData userOrSystem)
+ -- ^ old rules from the previous build
+ -> IORef (Set RuleId)
+ -- ^ rules that have been re-run
+ -> RuleId
+ -> RuleData userOrSystem
+ -> [Rule.Dependency]
+ -- ^ dynamic dependencies of this rule
+ -> IO Bool
+ruleUpToDate mbWorkDir oldRules staleRulesRef rId rule dynDeps = do
+ staleRules <- readIORef staleRulesRef
+ if ruleChanged || any (`Set.member` staleRules) ruleDeps
+ then return False
+ else do
+ let maybeModTime fp = handleDoesNotExist Nothing $ Just <$> getModificationTime fp
+ outMtimes <- traverse maybeModTime outputPaths
+ case sequenceA outMtimes of
+ -- At least one output is missing: must run the rule.
+ Nothing -> return False
+ Just outs ->
+ -- Re-run if an input is more recent than the oldest output.
+ case inputPaths of
+ [] -> return True
+ _ -> do
+ inMtimes <- traverse getModificationTime inputPaths
+ return (minimum outs >= maximum inMtimes)
+ where
+ i (Location dir file) = interpretSymbolicPath mbWorkDir (dir file)
+ allDeps = staticDependencies rule ++ dynDeps
+ ruleDeps = [outputOfRule ro | RuleDependency ro <- allDeps]
+ fileDeps = [loc | FileDependency loc <- allDeps]
+ inputPaths = map i fileDeps
+ outputPaths = fmap i (results rule)
+ ruleChanged =
+ case Map.lookup rId oldRules of
+ Just oldRule ->
+ -- Use the Eq instance to determine if the rule has changed
+ -- (as documented in the API).
+ oldRule /= rule
+ Nothing -> True
+
resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location
resolveDependency verbosity rId allRules = \case
FileDependency l -> return l
diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs
index 53b89a1e41a..1cee0fa14c8 100644
--- a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs
+++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs
@@ -267,6 +267,8 @@ deriving stock instance Eq (RuleData User)
deriving stock instance Eq (RuleData System)
deriving anyclass instance Binary (RuleData User)
deriving anyclass instance Binary (RuleData System)
+deriving anyclass instance Structured (RuleData User)
+deriving anyclass instance Structured (RuleData System)
-- | Trimmed down 'Show' instance, mostly for error messages.
instance Show RuleBinary where
@@ -673,6 +675,10 @@ data
}
-> RuleCommands scope deps ruleCmd
+-- NB: whenever you change this datatype, you **must** also update its
+-- 'Structured' instance. The structure hash is used as a handshake when
+-- communicating with an external hooks executable.
+
{- Note [Hooks Binary instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Hooks API is strongly typed: users can declare rule commands with varying
@@ -1081,6 +1087,35 @@ instance
-- that involve existential quantification.
data family Tok (arg :: Symbol) :: k
+instance
+ (Typeable scope, Typeable ruleCmd, Typeable deps)
+ => Structured (RuleCommands scope deps ruleCmd)
+ where
+ structure _ =
+ Structure
+ tr
+ 0
+ (show tr)
+ [
+ ( "StaticRuleCommand"
+ ,
+ [ nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (IO ()))
+ , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "arg" :: Hs.Type))
+ ]
+ )
+ ,
+ ( "DynamicRuleCommands"
+ ,
+ [ nominalStructure $ Proxy @(Static scope (Dict (Binary (Tok "depsRes"), Show (Tok "depsRes"), Eq (Tok "depsRes"))))
+ , nominalStructure $ Proxy @(deps scope (Tok "depsArg") (Tok "depsRes"))
+ , nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (Tok "depsRes" -> IO ()))
+ , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "depsArg", Tok "depsRes", Tok "arg"))
+ ]
+ )
+ ]
+ where
+ tr = Typeable.SomeTypeRep $ Typeable.typeRep @(RuleCommands scope deps ruleCmd)
+
instance
( forall res. Binary (ruleCmd System LBS.ByteString res)
, Binary (deps System LBS.ByteString LBS.ByteString)
diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs
index a9c21ecd9a3..fd6b3756ebb 100644
--- a/Cabal/src/Distribution/Simple/SrcDist.hs
+++ b/Cabal/src/Distribution/Simple/SrcDist.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
@@ -311,7 +312,7 @@ prepareTree
-> IO ()
prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do
ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps
- installOrdinaryFiles verbosity targetDir (zip (repeat []) $ map i ordinary)
+ installOrdinaryFiles verbosity targetDir (map (([],) . i) ordinary)
maybeCreateDefaultSetupScript targetDir
where
i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs
index ce407028a2f..fba96b9352f 100644
--- a/Cabal/src/Distribution/Simple/Test.hs
+++ b/Cabal/src/Distribution/Simple/Test.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
@@ -54,9 +55,7 @@ import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDir
import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..))
import System.Directory
( createDirectoryIfMissing
- , doesFileExist
, listDirectory
- , removeFile
)
-- | Perform the \"@.\/setup test@\" action.
@@ -134,7 +133,7 @@ test args verbHandles pkg_descr lbi0 flags = do
dieWithException verbosity NoTestSuitesEnabled
testsToRun <- case testNames of
- [] -> return $ zip enabledTests $ repeat Nothing
+ [] -> return $ map (,Nothing) enabledTests
names -> for names $ \tName ->
let testMap = zip enabledNames enabledTests
enabledNames = map (PD.testName . fst) enabledTests
@@ -151,8 +150,7 @@ test args verbHandles pkg_descr lbi0 flags = do
-- Delete ordinary files from test log directory.
listDirectory (i testLogDir)
- >>= filterM doesFileExist . map (i testLogDir )
- >>= traverse_ removeFile
+ >>= traverse_ (removeFileForcibly . (i testLogDir ))
-- 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
diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
index fb3e0a8b9a8..722d83d554e 100644
--- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs
+++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
@@ -20,6 +20,7 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI
, buildDir
, depLibraryPaths
)
+
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Run
@@ -27,7 +28,7 @@ import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Test
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
-import Distribution.System
+import Distribution.System (Platform (Platform))
import Distribution.TestSuite
import qualified Distribution.Types.LocalBuildInfo as LBI
( LocalBuildInfo (..)
diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs
index 058d2057140..71fa7c985f4 100644
--- a/Cabal/src/Distribution/Simple/Test/LibV09.hs
+++ b/Cabal/src/Distribution/Simple/Test/LibV09.hs
@@ -48,7 +48,6 @@ import System.Directory
, createDirectoryIfMissing
, doesFileExist
, getCurrentDirectory
- , removeFile
, removePathForcibly
, setCurrentDirectory
)
@@ -91,7 +90,7 @@ runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do
-- Write summary notices indicating start of test suite
notice verbosity $ summarizeSuiteStart testName'
- suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
+ suiteLog <- CE.bracket openCabalTemp removeFileForcibly $ \tempLog -> do
-- Compute the appropriate environment for running the test suite
let progDb = LBI.withPrograms lbi
pathVar = progSearchPath progDb
@@ -209,10 +208,6 @@ runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do
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"
diff --git a/Cabal/src/Distribution/Simple/UHC.hs b/Cabal/src/Distribution/Simple/UHC.hs
index 69c2033a70d..8d264d521c2 100644
--- a/Cabal/src/Distribution/Simple/UHC.hs
+++ b/Cabal/src/Distribution/Simple/UHC.hs
@@ -125,8 +125,8 @@ getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do
let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs)
-- putStrLn $ "pkgdirs: " ++ show pkgDirs
pkgs <-
- liftM (map addBuiltinVersions . concat) $
- traverse
+ map addBuiltinVersions . concat
+ <$> traverse
(\d -> listDirectory d >>= filterM (isPkgDir (prettyShow compilerid) d))
pkgDirs
-- putStrLn $ "pkgs: " ++ show pkgs
@@ -231,9 +231,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do
-- 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))
+ ++ map (map (\c -> if c == '.' then pathSeparator else c) . prettyShow) (allLibModules lib clbi)
runUhcProg uhcArgs
diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs
index 64d0fd09541..420dfbc144e 100644
--- a/Cabal/src/Distribution/Simple/Utils.hs
+++ b/Cabal/src/Distribution/Simple/Utils.hs
@@ -97,6 +97,9 @@ module Distribution.Simple.Utils
, copyFileTo
, copyFileToCwd
+ -- * removing files
+ , removeFileForcibly
+
-- * installing files
, installOrdinaryFile
, installExecutableFile
@@ -244,6 +247,7 @@ import Data.Typeable
( cast
)
+import Control.Concurrent (threadDelay)
import qualified Control.Exception as Exception
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import qualified Data.Version as DV
@@ -1812,6 +1816,26 @@ copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do
copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)
+-- | A robust helper to remove an existing file, which does not throw
+-- an exception if such file never existed, thus akin to removePathForcibly.
+removeFileForcibly :: FilePath -> IO ()
+removeFileForcibly fp = catch (removeFile fp) $ \case
+ e
+ -- If the file never existed in the first place, we are golden.
+ | isDoesNotExistError e -> pure ()
+ -- If we got a permission error, chances are that it's a read-only
+ -- file on Windows. Removing read-only attribute ourselves requires
+ -- reaching out for internal API, so instead of it we call 'removePathForcibly',
+ -- which is a bit of overkill for a single file, but well.
+ | isPermissionError e -> removePathForcibly fp
+ -- If device is busy, wait 1ms and give it another go.
+ -- EBUSY from unlink(2) is mapped to UnsatisfiedConstraints.
+ | ioeGetErrorType e == GHC.UnsatisfiedConstraints -> do
+ threadDelay 1000
+ removeFile fp
+ -- Else we give up.
+ | otherwise -> throwIO e
+
-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)
diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs
index f525d397aba..24ebebbbd6f 100644
--- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs
+++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs
@@ -132,6 +132,7 @@ import qualified Data.Map as Map
import Distribution.Compat.Graph (Graph)
import qualified Distribution.Compat.Graph as Graph
+import GHC.Stack (HasCallStack)
import qualified System.FilePath as FilePath (takeDirectory)
-- | Data cached after configuration step. See also
@@ -417,7 +418,7 @@ withAllTargetsInBuildOrder' pkg_descr lbi f =
-- 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' :: HasCallStack => 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)
diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs
index b8484eecc14..f2631d77100 100644
--- a/Cabal/src/Distribution/Utils/LogProgress.hs
+++ b/Cabal/src/Distribution/Utils/LogProgress.hs
@@ -4,10 +4,13 @@
module Distribution.Utils.LogProgress
( LogProgress
, runLogProgress
+ , runLogProgress'
, warnProgress
, infoProgress
, dieProgress
, addProgressCtx
+ , eitherToLogProgress
+ , ErrMsg
) where
import Distribution.Compat.Prelude
@@ -16,11 +19,11 @@ import Prelude ()
import Distribution.Simple.Utils
import Distribution.Utils.Progress
import Distribution.Verbosity
-import System.IO (hPutStrLn)
+import System.IO (hFlush, hPutStr, hPutStrLn)
import Text.PrettyPrint
type CtxMsg = Doc
-type LogMsg = Doc
+data LogMsg = WarnMsg Doc | InfoMsg Doc
type ErrMsg = Doc
data LogEnv = LogEnv
@@ -55,25 +58,46 @@ runLogProgress verbosity (LogProgress m) =
, le_context = []
}
step_fn :: LogMsg -> IO a -> IO a
- step_fn doc go = do
+ step_fn (WarnMsg doc) go = do
+ -- Log the warning to the stderr handle, but flush the stdout handle first,
+ -- to prevent interleaving (see Distribution.Simple.Utils.warnMessage).
+ let h = verbosityErrorHandle verbosity
+ flags = verbosityFlags verbosity
+ hFlush (verbosityChosenOutputHandle verbosity)
+ hPutStr h $ withOutputMarker flags (render doc ++ "\n")
+ go
+ step_fn (InfoMsg doc) go = do
+ -- Don't mark 'infoProgress' messages (mostly Backpack internals)
hPutStrLn (verbosityChosenOutputHandle verbosity) (render doc)
go
- fail_fn :: Doc -> IO a
+ fail_fn :: ErrMsg -> IO a
fail_fn doc = do
dieNoWrap verbosity (render doc)
+-- | Run 'LogProgress' ignoring all traces.
+runLogProgress' :: LogProgress a -> Either ErrMsg a
+runLogProgress' (LogProgress m) = foldProgress (\_ x -> x) Left Right (m env)
+ where
+ env =
+ LogEnv
+ { le_verbosity = mkVerbosity defaultVerbosityHandles silent
+ , le_context = []
+ }
+
-- | Output a warning trace message in 'LogProgress'.
warnProgress :: Doc -> LogProgress ()
warnProgress s = LogProgress $ \env ->
when (verbosityLevel (le_verbosity env) >= Normal) $
stepProgress $
- hang (text "Warning:") 4 (formatMsg (le_context env) s)
+ WarnMsg $
+ hang (text "Warning:") 4 (formatMsg (le_context env) s)
-- | Output an informational trace message in 'LogProgress'.
infoProgress :: Doc -> LogProgress ()
infoProgress s = LogProgress $ \env ->
when (verbosityLevel (le_verbosity env) >= Verbose) $
- stepProgress s
+ stepProgress $
+ InfoMsg s
-- | Fail the computation with an error message.
dieProgress :: Doc -> LogProgress a
@@ -89,3 +113,7 @@ formatMsg ctx doc = doc $$ vcat ctx
addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a
addProgressCtx s (LogProgress m) = LogProgress $ \env ->
m env{le_context = s : le_context env}
+
+eitherToLogProgress :: Either Doc a -> LogProgress a
+eitherToLogProgress (Left err) = dieProgress err
+eitherToLogProgress (Right a) = return a
diff --git a/Cabal/src/Distribution/Utils/MapAccum.hs b/Cabal/src/Distribution/Utils/MapAccum.hs
index d39001d8d29..e4ac8167d54 100644
--- a/Cabal/src/Distribution/Utils/MapAccum.hs
+++ b/Cabal/src/Distribution/Utils/MapAccum.hs
@@ -24,4 +24,4 @@ mapAccumM
-> a
-> t b
-> m (a, t c)
-mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s
+mapAccumM f s t = runStateM (traverse (\x -> StateM (`f` x)) t) s
diff --git a/MAINTAINERS.md b/MAINTAINERS.md
index b9268c0f2c5..c3f80607b37 100644
--- a/MAINTAINERS.md
+++ b/MAINTAINERS.md
@@ -1,6 +1,13 @@
-## List of Maintainers
+# Cabal maintainer documentation
-a.k.a. The Cabal Maintainers Team:
+This document outlines some of the things that cabal maintainers should know. Contributors shouldn't need anything in here, unless they're working on the CI system or need an executive decision from a repo maintainer below. (If you find that you do, please open an issue pointing out what needs to be moved to the contributor documentation.)
+
+This is a first draft; many things are as yet missing. Open an issue if you need something added here.
+
+
+## Maintainers
+
+The Cabal Maintainers Team consists of:
* Mikolaj Konarski ([`@Mikolaj`](https://github.com/Mikolaj), mikolaj@well-typed.com, [`ce1ed8ae0b011d8c`](https://keyserver.ubuntu.com/pks/lookup?op=vindex&search=0xce1ed8ae0b011d8c))
@@ -10,11 +17,7 @@ a.k.a. The Cabal Maintainers Team:
* Brandon Allbery ([`@geekosaur`](https://github.com/geekosaur), allbery.b@gmail.com, [`227ee1942b0bdb95`](https://keyserver.ubuntu.com/pks/lookup?op=vindex&search=0x227ee1942b0bdb95))
-### How we compose this list
-
-The main goal of the team is to ensure that Cabal is keeping up with the ever-evolving Haskell ecosystem.
-In practical terms this means producing releases of the packages in this repository on a regular basis: we usually have to release at least as often as does GHC due to an intimate connection between the compiler and the build system.
-Hence, the people listed above (in chronological order by when they joined the team) are those who are currently available for carrying out the release procedures.
+The main goal of the team is to ensure that Cabal is keeping up with the ever-evolving Haskell ecosystem. In practical terms this means producing releases of the packages in this repository on a regular basis: we usually have to release at least as often as does GHC due to an intimate connection between the compiler and the build system. Hence, the people listed above (in chronological order by when they joined the team) are those who are currently available for carrying out the release procedures.
Successful maintenance requires coordination, and the team engages in three main ways:
@@ -22,9 +25,118 @@ Successful maintenance requires coordination, and the team engages in three main
- discussing Cabal on the [Matrix channel](https://matrix.to/#/#hackage:matrix.org);
-- meeting biweekly in video calls with agenda prepared asynchronously in a Markdown document, which also holds the meeting notes.
+- meeting biweekly in video calls with agenda prepared asynchronously in a [Markdown document](https://hackmd.io/ytXS6xrAS2mTyPVxdUS6OA?both), which also holds the meeting notes.
Worth noting that the meetings are open to everyone interested in Cabal, especially aspiring and returning Cabal contributors. Ask on Matrix how to join.
-Most of the current team are volunteers, and we are happy to receive any help.
-If you want to participate in Cabal maintenance as defined above (e.g. take on some release tasks), get in touch: open a GitHub discussion or send a message on Matrix.
+Most of the current team are volunteers, and we are happy to receive any help. If you want to participate in Cabal maintenance as defined above (e.g. take on some release tasks), get in touch: open a GitHub discussion or send a message on Matrix.
+
+
+## Workflows
+
+The standard workflows are:
+
+- `bootstrap.yml`: bootstrap a cabal from prepared JSONs (see `make bootstrap-jsons`)
+- `validate.yml`: build a cabal with extra assertions and run the full test suite on it
+- `changelogs.yml`: validate `changelog.d` files using [`changelog-d`]
+- `dependabot.yml`: check `dependabot` configuration (sadly, not automatic; we lifted this from Ubuntu's CI)
+- `lint.yml`: run `hlint` on cabal sources
+- `format.yml`: check source formatting using Fourmolu v0.12
+- `quick-jobs.yml`: various (formerly) quick checks
+- `release.yaml`: build devel / release binaries for multiple platforms
+- `typos.yml`: look for typos in documentation
+- `users-guide.yml`: generate the users guide, creating an artifact
+- `whitespace.yml`: check for extraneous whitespace in various files
+- `check-sdist.yml`: make sure cabal can be built against the `Cabal` bootlib (see e.g. #10931, #9863)
+- `release.yml`: build release binaries, either as part of a release or for testing
+
+The validate workflow performs a number of tests on tier-1 platforms:
+
+- on current GHCs (see the list of ghc versions in the jobs `matrix` in `validate.yml`) it runs through the full suite of tests (`lib-tests`, `lib-suite`, `cli-tests`, and `cli-suite`)
+- on older GHCs (see the `extra-ghc` entries in `validate-old-ghcs`) it only runs `lib-suite-extras`, which is a cut-down test suite
+- it builds but doesn't validate (for some reason) a static `cabal` on Alpine with MUSL
+- it dogfoods `cabal` by having it build itself
+
+You can use a manual dispatch on the validate workflow. It has two optional parameters:
+- `allow-newer line` will add an `allow-newer:` entry to the project file. Don't include the prefix.
+- `constraints line` will similarly add a `constraints:` entry.
+
+The bootstrap workflow verifies that cabal can be built from pregenerated JSONs, for use in bootstrapping cabal on a new platform (since cabal is self-hosted). Note that, while we test this on release branches currently, bootstrapping is only supported from `master`.
+
+The release workflow tests that PRs result in releasable `cabal`s, and is also used to produce `cabal` for releases. It can be dispatched manually or via a label `run release build`. It also performs daily draft releases starting at 00:00 UTC. It builds, tests, and releases for a wide variety of platforms, not all of which are considered Tier I for cabal development. (See list of tiers below.)
+
+
+## Actions
+
+Currently there is only one local action:
+
+- `reusable-release.yaml`: the actual guts of `release.yaml` above.
+
+The `validate-actions` branch in development will add more reusable actions for `validate.yml` in order to reduce duplication and make it more maintainable, and at that time `reusable-release` will likely be moved with the other reusable actions.
+
+
+## Support tiers
+
+Currently we support the following platforms as Tier 1:
+
+- MacOS on AArch64
+- X86-64 (aka AMD64)
+- Windows (10 and 11)
+
+Tier 2 platforms are:
+
+- FreeBSD (AMD64 only)
+- Alpine/MUSL static build
+- MacOS on Intel
+- X86 (deprecated)
+- ARM Linux (Debian and Alpine)
+
+We do not currently test on tier 2 platforms, but support for that is coming.
+
+
+## CI
+
+Mergify requires 2 approvals and a 2-day cooldown period before merging on `master`. Release branches are different, because we don't normally commit directly to them except during a release.
+
+The rules for PRs on release branches are:
+
+- only 1 approval needed for backports via Mergify (`@mergifyio backport branch`), otherwise 2 as usual
+- no cooldown period, since either it's a backport of a PR that already received scrutiny or we're in the middle of a release and need things to move along
+
+Note that you should not make (or approve) a PR directly to a release branch, unless it's necessary for release (usually this would be changelogs, but occasionally is needed for manual backports with conflicts).
+
+
+## GPG keys
+
+All maintainers who are authorized to make release binaries should have GPG keys cross-signed with other maintainers' keys. @f-a and @geekosaur can help with this if a new maintainer is onboarded.
+
+
+## Releases
+
+Notes for how to make a release are at the
+wiki page ["Making a release"](https://github.com/haskell/cabal/wiki/Making-a-release).
+Currently, [@emilypi](https://github.com/emilypi), [@fgaz](https://github.com/fgaz) and [@Mikolaj](https://github.com/Mikolaj) have access to
+`haskell.org/cabal`, and [@Mikolaj](https://github.com/Mikolaj) is the point of contact for getting
+permissions.
+
+
+## Hackage Revisions
+
+We have a CI setup to test that our main pipeline ("Validate") accepts a proposed revision. To use
+it, go to the
+[Validate workflow page](https://github.com/haskell/cabal/actions/workflows/validate.yml)
+and dispatch it manually by clicking "Run workflow". As noted above in ["Workflows"](#workflows),
+you can specify `allow-newer:` and `constraints:` entries reflecting the proposed revision.
+
+For example, imagine that Cabal only allows `tar` or version less then
+or equal to 0.6, and you want to bump it to 0.6. Then, to show that Validate
+succeeds with `tar` 0.6, you should input
+
+- `tar` for the `allow-newer line`
+- `tar ==0.6` for the `constraints line`
+
+Hopefully, running the Validate pipeline with these inputs succeeds, and you
+should link to the run in the ticket about bumping the bound and making a revision.
+
+If you are interested in the technical details, refer to the parts of `validate.yml` that
+mention `hackage-revisions`.
diff --git a/Makefile b/Makefile
index 9b0cae9f668..a9b9ee5e71f 100644
--- a/Makefile
+++ b/Makefile
@@ -31,7 +31,8 @@ FORMAT_DIRS := \
Cabal-syntax \
cabal-install \
cabal-testsuite/src \
- cabal-validate
+ cabal-validate \
+ Cabal-tests/exes
FORMAT_DIRS_TODO := \
Cabal-QuickCheck \
@@ -49,7 +50,7 @@ FORMAT_DIRS_TODO := \
solver-benchmarks
.PHONY: style-todo
-style-todo: ## Configured for fourmolu, avoiding GHC parser failures
+style-todo: ## Configured for fourmolu, avoiding GHC parser failures.
@fourmolu -q $(FORMAT_DIRS_TODO) > /dev/null
.PHONY: style
@@ -85,7 +86,7 @@ lint-json: ## Run HLint in JSON mode.
# local checks
.PHONY: checks
-checks: whitespace users-guide-typos markdown-typos style lint-json ## Run all local checks; whitespace, typos, style, and lint.
+checks: whitespace users-guide-typos markdown-typos style lint-json ## Run all local checks: whitespace, typos, style, and lint.
# source generation: SPDX
@@ -156,11 +157,6 @@ doctest: ## Run doctests.
cd cabal-install-solver && $(DOCTEST)
cd cabal-install && $(DOCTEST)
-# This is not run as part of validate.sh (we need hackage-security, which is tricky to get).
-.PHONY: doctest-cli
-doctest-cli :
- doctest -D__DOCTEST__ --fast cabal-install/src cabal-install-solver/src cabal-install-solver/src-assertion
-
.PHONY: doctest-install
doctest-install: ## Install doctest tool needed for running doctests.
cabal install doctest --overwrite-policy=always --ignore-project --flag cabal-doctest
@@ -265,17 +261,55 @@ tags: ## Generate editor tags, vim ctags and emacs etags.
# bootstrapping
##############################################################################
+BOOT_GHCUP := $(shell ghcup --version 2>/dev/null)
+BOOT_NIX := $(shell nix-shell --version 2>/dev/null)
+CABALCONF := $(shell if test -f $$HOME/.config/cabal/config; then echo CABAL_CONFIG=$$HOME/.config/cabal/config; fi)
+
bootstrap-json-%: phony
- cabal build --project-file=cabal.bootstrap.project --with-compiler=ghc-$* --dry-run cabal-install:exe:cabal
- cp dist-newstyle/cache/plan.json bootstrap/linux-$*.plan.json
+ ghcup install ghc "$*" --no-verbose --no-guess-version
+ $(MAKE) "bootstrap-subr-$*"
+
+# "subroutine", make style
+bootstrap-subr-%: phony
+ rm -rf dist-bootstrap
+ $(CABALBUILD) --distdir=dist-bootstrap --project-file=cabal.bootstrap.project --with-compiler=ghc-$* --dry-run \
+ cabal-install:exe:cabal
+ cp dist-bootstrap/cache/plan.json bootstrap/linux-$*.plan.json
@# -v0 to avoid build output on stdout
- cd bootstrap && cabal run -v0 cabal-bootstrap-gen -- linux-$*.plan.json \
+ cd bootstrap && $(CABALCONF) $(CABALRUN) -v0 cabal-bootstrap-gen -- linux-$*.plan.json \
| python3 -m json.tool > linux-$*.json
-BOOTSTRAP_GHC_VERSIONS := 9.2.8 9.4.8 9.6.7 9.8.4 9.10.2 9.12.2
+BOOTSTRAP_GHC_VERSIONS := 9.2.8 9.4.8 9.6.7 9.8.4 9.10.3 9.12.2
.PHONY: bootstrap-jsons
-bootstrap-jsons: $(BOOTSTRAP_GHC_VERSIONS:%=bootstrap-json-%)
+bootstrap-jsons: ## Generate bootstrap JSONs for Linux (autodetects method).
+ifeq ($(BOOT_GHCUP), )
+ifeq ($(BOOT_NIX), )
+ @echo If you do not have the following ghc versions, you will need to install them manually.
+ @echo They can be obtained from https://downloads.haskell.org/ghc.
+ @echo " " $(BOOTSTRAP_GHC_VERSIONS)
+ $(MAKE) bootstrap-jsons-no-dl
+else
+ $(MAKE) bootstrap-jsons-nix
+endif
+else
+ $(MAKE) bootstrap-jsons-ghcup
+endif
+
+.PHONY: bootstrap-jsons-no-dl
+bootstrap-jsons-no-dl: $(BOOTSTRAP_GHC_VERSIONS:%=bootstrap-subr-%) ## Generate bootstrap JSONs for Linux using existing ghcs.
+
+.PHONY: bootstrap-jsons-nix
+bootstrap-jsons-nix: ## Generate bootstrap JSONs for Linux using Nix-provided ghcs.
+ cd ./bootstrap && $(CABALCONF) ./generate_bootstrap_plans
+
+.PHONY: bootstrap-jsons-ghcup
+bootstrap-jsons-ghcup: $(BOOTSTRAP_GHC_VERSIONS:%=bootstrap-json-%) ## Generate bootstrap JSONs for Linux using ghcup.
+
+# this lets the Nix bootstrap script use the Makefile's definitions instead of hardcoding them itself
+.PHONY: bootstrap-jsons-nix-helper
+bootstrap-jsons-nix-helper:
+ @echo "$(BOOTSTRAP_GHC_VERSIONS)"
# documentation
##############################################################################
@@ -290,12 +324,12 @@ else
PROCS := $(shell nproc)
endif
-PHONY: help
+.PHONY: help
help: ## Show the commented targets.
@grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | \
sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}'
-PHONY: help-banner
+.PHONY: help-banner
help-banner: ## Show the help banner.
@echo "===================================================================="
@echo "§ all make with no arguments also shows this banner"
@@ -303,32 +337,32 @@ help-banner: ## Show the help banner.
@echo "===================================================================="
.PHONY: typos-install
-typos-install: ## Install typos-cli for typos target using cargo
+typos-install: ## Install typos-cli for typos target using cargo.
cargo install typos-cli
GREP_EXCLUDE := grep -v -E 'dist-|cabal-testsuite|python-'
FIND_NAMED := find . -type f -name
.PHONY: hs-typos
-hs-typos: ## Find typos in Haskell source files; .hs, .cabal, etc.
+hs-typos: ## Find typos in Haskell source files: .hs, .cabal, etc.
typos --config .typos-srcs.toml --force-exclude
.PHONY: hs-fix-typos
-hs-fix-typos: ## Fix typos in Haskell source files; .hs, .cabal, etc.
+hs-fix-typos: ## Fix typos in Haskell source files: .hs, .cabal, etc.
typos --config .typos-srcs.toml --write-changes --force-exclude
.PHONY: users-guide-typos
-users-guide-typos: ## Find typos in users guide
+users-guide-typos: ## Find typos in users guide.
cd doc && $(FIND_NAMED) '*.rst' | xargs typos --config ../.typos-docs.toml --force-exclude
.PHONY: users-guide-fix-typos
-users-guide-fix-typos: ## Fix typos in users guide
+users-guide-fix-typos: ## Fix typos in users guide.
cd doc && $(FIND_NAMED) '*.rst' | xargs typos --config ../.typos-docs.toml --write-changes --force-exclude
.PHONY: markdown-typos
-markdown-typos: ## Find typos in markdown files
+markdown-typos: ## Find typos in markdown files.
$(FIND_NAMED) '*.md' | $(GREP_EXCLUDE) | xargs typos --config .typos-docs.toml --force-exclude
.PHONY: markdown-fix-typos
-markdown-fix-typos: ## Fix typos in markdown files
+markdown-fix-typos: ## Fix typos in markdown files.
$(FIND_NAMED) '*.md' | $(GREP_EXCLUDE) | xargs typos --config .typos-docs.toml --write-changes --force-exclude
diff --git a/README.md b/README.md
index 9e6d2b8c9d6..993faf6bd01 100644
--- a/README.md
+++ b/README.md
@@ -112,6 +112,32 @@ If you are new to `cabal` and want to quickly learn the basics, check
Got questions? Ask in [Haskell Matrix](https://matrix.to/#/#haskell:matrix.org)
(online chat) or [Haskell Discourse](https://discourse.haskell.org).
+Support window
+--------------
+
+Our GHC support window is five years ([reference](https://gitlab.haskell.org/ghc/ghc/-/wikis/GHC%20Status#all-released-ghc-versions))
+for both the Cabal library and `cabal-install`. That is:
+
+* Cabal library must be buildable out-of-the-box against the
+ boot libraries shipped with GHC, for any GHC released in the past five
+ years from Cabal library release date.
+* `cabal-install` should be buildable with `bootstrap/bootstrap.py`
+ script, for any GHC released in the past five years from `cabal-install`
+ release date.
+* `cabal-install` should be able to drive the most recent minor version of
+ any GHCs major version released in the past five years from `cabal-install`
+ release date.
+ In this context, "drive" means `cabal-install` will work with the Cabal
+ library (usually but not always the one that came with the ghc version)
+ used to build the package.
+
+Self-upgrade to the latest version (i.e. `cabal install cabal-install`)
+must work with all versions of `cabal-install` released during the last
+three years.
+
+Cabal maintainers try to support GHC versions older than five years
+on a minimal-effort basis.
+
Build for hacking and contributing to cabal
-------------------------------------------
diff --git a/bootstrap/README.md b/bootstrap/README.md
index e41f13d691c..4082e1c4f75 100644
--- a/bootstrap/README.md
+++ b/bootstrap/README.md
@@ -33,7 +33,7 @@ in the same way as it is shown for Linux above. On a system with functional `cab
1. Install the same GHC version as you will use to bootstrap on the host system.
-2. Build a dependency description file (`$PLATFORM-$GHCVER.json`, e.g. `macosx-8.8.4.json`) by running:
+2. Build a dependency description file (`$PLATFORM-$GHCVER.json`, e.g. `macosx-8.8.4.json`).
```sh
cabal build --with-compiler=/path/to/ghc --dry-run cabal-install:exe:cabal
@@ -45,15 +45,8 @@ in the same way as it is shown for Linux above. On a system with functional `cab
3. You may need to tweak `bootstrap/$PLATFORM-$GHCVER.json` file manually,
for example, to toggle flags.
-There are rules in the top-level `Makefile` for generation of these files.
-
-# Updating Bootstrap Plans
-
-In order to update the bootstrap plans on linux there is the convenient `./generate_bootstrap_plans`
-script. You can modify this script with the GHC versions you want to generate the plans for and
-then run it to generate the plans.
-
-```
-./generate_bootstrap_plans
-```
-
+The top level `Makefile` has a rule `bootstrap-jsons` to generate Linux bootstrap files for all
+supported ghc versions, or `bootstrap-json-$GHCVER` for a single ghc version. The rules know
+how to obtain the requisite ghc versions via `ghcup` or Nix; if you have neither, you will
+have to obtain versioned ghc binaries from `downloads.haskell.org` or other suitable
+repository.
diff --git a/bootstrap/bootstrap.py b/bootstrap/bootstrap.py
index 47ce691abfc..5638b13648c 100755
--- a/bootstrap/bootstrap.py
+++ b/bootstrap/bootstrap.py
@@ -89,7 +89,9 @@ class PackageSource(Enum):
, "Cabal-tests"
, "Cabal-tree-diff"
, "cabal-install-solver"
- , "cabal-install" ]
+ , "cabal-install"
+ , "hooks-exe"
+ ]
# Value passed to setup build -j {jobs_amount}
# 1 is not set by default.
diff --git a/bootstrap/cabal-bootstrap-gen.cabal b/bootstrap/cabal-bootstrap-gen.cabal
index 47ed4be45d0..3b4a9f3bd52 100644
--- a/bootstrap/cabal-bootstrap-gen.cabal
+++ b/bootstrap/cabal-bootstrap-gen.cabal
@@ -9,8 +9,8 @@ executable cabal-bootstrap-gen
main-is: Main.hs
build-depends:
, aeson ^>=1.5.2.0 || ^>=2.0.3.0 || ^>=2.1.0.0 || ^>=2.2.0.0
- , base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0 || ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0 || ^>=4.18.0.0 || ^>=4.19.0.0 || ^>=4.20.0.0
- , bytestring ^>=0.10.8.2 || ^>=0.11.0.0
+ , base >=4.12.0.0 && < 5
+ , bytestring >=0.10.8.2 && <0.13
, Cabal ^>=3.14.1.0 || ^>=3.16.0.0
, Cabal-syntax ^>=3.14.1.0 || ^>=3.16.0.0
-- For the release process, we need the last *two* Cabal-syntax
@@ -20,7 +20,8 @@ executable cabal-bootstrap-gen
-- rerun `make bootstrap-jsons`.
, cabal-install-parsers ^>=0.6
, cabal-plan ^>=0.7.0.0
- , containers ^>=0.6.0.1
- , text ^>=1.2.3.0 || ^>=2.0.1
+ -- upper bound is conjectural
+ , containers >=0.6.0.1 && <0.10
+ , text >=1.2.3.0 && <3
, topograph ^>=1.0.0.1
, transformers ^>=0.5.6.2 || ^>=0.6.0.4
diff --git a/bootstrap/generate_bootstrap_plans b/bootstrap/generate_bootstrap_plans
deleted file mode 100755
index 4630ad5fa8b..00000000000
--- a/bootstrap/generate_bootstrap_plans
+++ /dev/null
@@ -1,23 +0,0 @@
-nix build nixpkgs#jq.bin -o jq
-PATH+=:$PWD/jq-bin/bin
-
-ghcs_nix="https://gitlab.haskell.org/bgamari/ghcs-nix/-/archive/master/ghcs-nix-master.tar.gz"
-
-nix build -f "$ghcs_nix" ghc-9_6_5 -o boot_ghc
-
-run() {
- local ver="$1"
- local drv="ghc-$ver"
- echo "$ver"
- nix build -f "$ghcs_nix" $drv
- (cd ../; rm -r dist-bootstrap; cabal --distdir=dist-bootstrap build --project-file=cabal.bootstrap.project --dry-run cabal-install:exe:cabal -w bootstrap/result/bin/ghc)
- jq --sort-keys < ../dist-bootstrap/cache/plan.json > "plan-$ver.json"
- cabal run --with-ghc-pkg $PWD/boot_ghc/bin/ghc-pkg -w $PWD/boot_ghc/bin/ghc -v0 cabal-bootstrap-gen -- "plan-$ver.json" | jq --sort-keys | tee "linux-$(echo $ver | tr "_" ".").json"
-}
-
-run "9_2_8"
-run "9_4_8"
-run "9_6_7"
-run "9_8_4"
-run "9_10_1"
-run "9_12_2"
diff --git a/bootstrap/generate_nix_bootstrap_plans b/bootstrap/generate_nix_bootstrap_plans
new file mode 100755
index 00000000000..2b7455a7d64
--- /dev/null
+++ b/bootstrap/generate_nix_bootstrap_plans
@@ -0,0 +1,30 @@
+#! /bin/sh
+# You should probably use `make bootstrap-jsons` from the top level directory
+# instead of running this script directly; it will automatically detect
+# ghcup and Nix, or tell you where to download the necessary ghcs.
+nix build nixpkgs#jq.bin -o jq --extra-experimental-features nix-command --extra-experimental-features flakes
+PATH="$PATH:$PWD/jq-bin/bin"
+
+ghcs_nix="https://gitlab.haskell.org/bgamari/ghcs-nix/-/archive/master/ghcs-nix-master.tar.gz"
+
+nix build -f "$ghcs_nix" ghc-9_6_5 -o boot_ghc --extra-experimental-features nix-command
+
+run() {
+ local ver="$1"
+ local drv="ghc-$ver"
+ echo "$ver"
+ nix build -f "$ghcs_nix" $drv --extra-experimental-features nix-command
+ (cd .. && rm -rf dist-bootstrap && cabal --distdir=dist-bootstrap build --project-file=cabal.bootstrap.project --dry-run cabal-install:exe:cabal -w bootstrap/result/bin/ghc)
+ jq --sort-keys < ../dist-bootstrap/cache/plan.json > "plan-$ver.json"
+ cabal run --with-ghc-pkg $PWD/boot_ghc/bin/ghc-pkg -w $PWD/boot_ghc/bin/ghc -v0 cabal-bootstrap-gen -- "plan-$ver.json" | jq --sort-keys | tee "linux-$(echo $ver | tr "_" ".").json"
+}
+
+if [ $# -eq 0 ]; then
+ # get bootstrap ghc list from Makefile instead of hardcoded
+ # MAKELEVEL silences sub-make output if this is run from the top level Makefile
+ set -- $(cd ..; MAKELEVEL= make bootstrap-jsons-nix-helper)
+fi
+
+for ghc in "$@"; do
+ run $(echo "$ghc" | tr . _)
+done
diff --git a/bootstrap/linux-9.10.2.json b/bootstrap/linux-9.10.3.json
similarity index 97%
rename from bootstrap/linux-9.10.2.json
rename to bootstrap/linux-9.10.3.json
index bf35aa995df..9784dc826ef 100644
--- a/bootstrap/linux-9.10.2.json
+++ b/bootstrap/linux-9.10.3.json
@@ -14,11 +14,11 @@
},
{
"package": "ghc-internal",
- "version": "9.1002.0"
+ "version": "9.1003.0"
},
{
"package": "base",
- "version": "4.20.1.0"
+ "version": "4.20.2.0"
},
{
"package": "array",
@@ -30,7 +30,7 @@
},
{
"package": "ghc-boot-th",
- "version": "9.10.2"
+ "version": "9.10.3"
},
{
"package": "pretty",
@@ -66,7 +66,7 @@
},
{
"package": "os-string",
- "version": "2.0.4"
+ "version": "2.0.7"
},
{
"package": "filepath",
@@ -78,7 +78,7 @@
},
{
"package": "unix",
- "version": "2.8.6.0"
+ "version": "2.8.7.0"
},
{
"package": "directory",
@@ -90,7 +90,7 @@
},
{
"package": "text",
- "version": "2.1.2"
+ "version": "2.1.3"
},
{
"package": "parsec",
@@ -429,6 +429,16 @@
"src_sha256": "1def1a524cc894351e28e86a91cf2d043f18eeaba79070e1cc1304c9f79e4c17",
"version": "0.6.3.1"
},
+ {
+ "cabal_sha256": null,
+ "component": "lib:hooks-exe",
+ "flags": [],
+ "package": "hooks-exe",
+ "revision": null,
+ "source": "local",
+ "src_sha256": null,
+ "version": "0.1"
+ },
{
"cabal_sha256": "a5effff3d14a0bbfde51dd62e72cff069b56be4298f16a78db7d3cc0c678c859",
"component": "lib:open-browser",
diff --git a/bootstrap/linux-9.12.2.json b/bootstrap/linux-9.12.2.json
index f8f74b8d3a5..ba77f17a3ac 100644
--- a/bootstrap/linux-9.12.2.json
+++ b/bootstrap/linux-9.12.2.json
@@ -421,6 +421,16 @@
"src_sha256": "1def1a524cc894351e28e86a91cf2d043f18eeaba79070e1cc1304c9f79e4c17",
"version": "0.6.3.1"
},
+ {
+ "cabal_sha256": null,
+ "component": "lib:hooks-exe",
+ "flags": [],
+ "package": "hooks-exe",
+ "revision": null,
+ "source": "local",
+ "src_sha256": null,
+ "version": "0.1"
+ },
{
"cabal_sha256": "a5effff3d14a0bbfde51dd62e72cff069b56be4298f16a78db7d3cc0c678c859",
"component": "lib:open-browser",
diff --git a/bootstrap/linux-9.2.8.json b/bootstrap/linux-9.2.8.json
index f75f37072b7..bb5fa19a0aa 100644
--- a/bootstrap/linux-9.2.8.json
+++ b/bootstrap/linux-9.2.8.json
@@ -479,6 +479,16 @@
"src_sha256": "1def1a524cc894351e28e86a91cf2d043f18eeaba79070e1cc1304c9f79e4c17",
"version": "0.6.3.1"
},
+ {
+ "cabal_sha256": null,
+ "component": "lib:hooks-exe",
+ "flags": [],
+ "package": "hooks-exe",
+ "revision": null,
+ "source": "local",
+ "src_sha256": null,
+ "version": "0.1"
+ },
{
"cabal_sha256": "a5effff3d14a0bbfde51dd62e72cff069b56be4298f16a78db7d3cc0c678c859",
"component": "lib:open-browser",
diff --git a/bootstrap/linux-9.4.8.json b/bootstrap/linux-9.4.8.json
index ff2bfc18db5..035b477b315 100644
--- a/bootstrap/linux-9.4.8.json
+++ b/bootstrap/linux-9.4.8.json
@@ -452,6 +452,16 @@
"src_sha256": "1def1a524cc894351e28e86a91cf2d043f18eeaba79070e1cc1304c9f79e4c17",
"version": "0.6.3.1"
},
+ {
+ "cabal_sha256": null,
+ "component": "lib:hooks-exe",
+ "flags": [],
+ "package": "hooks-exe",
+ "revision": null,
+ "source": "local",
+ "src_sha256": null,
+ "version": "0.1"
+ },
{
"cabal_sha256": "a5effff3d14a0bbfde51dd62e72cff069b56be4298f16a78db7d3cc0c678c859",
"component": "lib:open-browser",
diff --git a/bootstrap/linux-9.6.6.json b/bootstrap/linux-9.6.6.json
deleted file mode 100644
index c94c6580dc5..00000000000
--- a/bootstrap/linux-9.6.6.json
+++ /dev/null
@@ -1,532 +0,0 @@
-{
- "builtin": [
- {
- "package": "rts",
- "version": "1.0.2"
- },
- {
- "package": "ghc-prim",
- "version": "0.10.0"
- },
- {
- "package": "ghc-bignum",
- "version": "1.3"
- },
- {
- "package": "base",
- "version": "4.18.2.1"
- },
- {
- "package": "array",
- "version": "0.5.6.0"
- },
- {
- "package": "deepseq",
- "version": "1.4.8.1"
- },
- {
- "package": "ghc-boot-th",
- "version": "9.6.6"
- },
- {
- "package": "pretty",
- "version": "1.1.3.6"
- },
- {
- "package": "template-haskell",
- "version": "2.20.0.0"
- },
- {
- "package": "containers",
- "version": "0.6.7"
- },
- {
- "package": "bytestring",
- "version": "0.11.5.3"
- },
- {
- "package": "transformers",
- "version": "0.6.1.0"
- },
- {
- "package": "mtl",
- "version": "2.3.1"
- },
- {
- "package": "stm",
- "version": "2.5.1.0"
- },
- {
- "package": "exceptions",
- "version": "0.10.7"
- },
- {
- "package": "filepath",
- "version": "1.4.300.1"
- },
- {
- "package": "time",
- "version": "1.12.2"
- },
- {
- "package": "binary",
- "version": "0.8.9.1"
- },
- {
- "package": "text",
- "version": "2.0.2"
- },
- {
- "package": "parsec",
- "version": "3.1.16.1"
- }
- ],
- "dependencies": [
- {
- "cabal_sha256": "5b7f8afd7a879c3c8c3c636fd3c7543cdd5e0b514b7da90e76907ccd11434031",
- "component": "lib:unix",
- "flags": [
- "-os-string"
- ],
- "package": "unix",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "8117599bb3e4aa1d4656710afbc85aef2a75483eddfac5338f8cc88fb505eea2",
- "version": "2.8.6.0"
- },
- {
- "cabal_sha256": "e3e1866eab82cb28f6a5f28507643da3987008b737e66a3c7398f39f16d824dc",
- "component": "lib:file-io",
- "flags": [
- "-os-string"
- ],
- "package": "file-io",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "e3d9113a015c57e3d8c2294550c41544f84a265291fed96cca697f91b6e86f52",
- "version": "0.1.4"
- },
- {
- "cabal_sha256": "2490137bb7738bd79392959458ef5f276219ea5ba8a9a56d3e0b06315c1bb917",
- "component": "lib:directory",
- "flags": [
- "-os-string"
- ],
- "package": "directory",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "20a24846117fc5f8751d974b7de07210a161989410467e9adca525381b8e64cc",
- "version": "1.3.9.0"
- },
- {
- "cabal_sha256": "de553eefe0b6548a560e9d8100486310548470a403c1fa21108dd03713da5fc7",
- "component": "exe:alex",
- "flags": [],
- "package": "alex",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "c92efe86f8eb959ee03be6c04ee57ebc7e4abc75a6c4b26551215d7443e92a07",
- "version": "3.5.1.0"
- },
- {
- "cabal_sha256": null,
- "component": "lib:Cabal-syntax",
- "flags": [],
- "package": "Cabal-syntax",
- "revision": null,
- "source": "local",
- "src_sha256": null,
- "version": "3.15.0.0"
- },
- {
- "cabal_sha256": "9a0b2ef8096517fa0e0c7a5e9a5c2ae5744ed824c3331005f9408245810df345",
- "component": "lib:process",
- "flags": [],
- "package": "process",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "496fe0566c3915b112e9772ac9c967dfeb8d5ca04895e54ae0160522bee76e65",
- "version": "1.6.25.0"
- },
- {
- "cabal_sha256": null,
- "component": "lib:Cabal",
- "flags": [
- "-git-rev"
- ],
- "package": "Cabal",
- "revision": null,
- "source": "local",
- "src_sha256": null,
- "version": "3.15.0.0"
- },
- {
- "cabal_sha256": null,
- "component": "lib:Cabal-hooks",
- "flags": [],
- "package": "Cabal-hooks",
- "revision": null,
- "source": "local",
- "src_sha256": null,
- "version": "3.16"
- },
- {
- "cabal_sha256": "276325277350cd2c2c88916ed3ae5cd35b2b4f494ec594fbd9534081eb7fb759",
- "component": "exe:hsc2hs",
- "flags": [
- "-in-ghc-tree"
- ],
- "package": "hsc2hs",
- "revision": 3,
- "source": "hackage",
- "src_sha256": "6f4e34d788fe2ca7091ee0a10307ee8a7c060a1ba890f2bffad16a7d4d5cef76",
- "version": "0.68.10"
- },
- {
- "cabal_sha256": "b0fafb2834530084f6406017500ae619f9e5e2049787a6750c68e0d331fd62dc",
- "component": "lib:network",
- "flags": [
- "-devel"
- ],
- "package": "network",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "dbd8a10456908294eb5ab9c522bf2da75444d958429a643a821464213698523e",
- "version": "3.2.6.0"
- },
- {
- "cabal_sha256": "129a59ba3ccfcd06192fd6da899e2711ae276a466915a047bd6727e4a0321d2e",
- "component": "lib:th-compat",
- "flags": [],
- "package": "th-compat",
- "revision": 2,
- "source": "hackage",
- "src_sha256": "81f55fafc7afad7763c09cb8b7b4165ca3765edcf70ffa42c7393043a1382a1e",
- "version": "0.1.5"
- },
- {
- "cabal_sha256": "6fffb57373962b5651a2db8b0af732098b3bf029a7ced76a9855615de2026588",
- "component": "lib:network-uri",
- "flags": [],
- "package": "network-uri",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "9c188973126e893250b881f20e8811dca06c223c23402b06f7a1f2e995797228",
- "version": "2.6.4.2"
- },
- {
- "cabal_sha256": "b90ce97917703f6613ed5a8cfe1a51525b990244f5610509baa15c8499eadca3",
- "component": "lib:HTTP",
- "flags": [
- "-conduit10",
- "+network-uri",
- "-warn-as-error",
- "-warp-tests"
- ],
- "package": "HTTP",
- "revision": 4,
- "source": "hackage",
- "src_sha256": "df31d8efec775124dab856d7177ddcba31be9f9e0836ebdab03d94392f2dd453",
- "version": "4000.4.1"
- },
- {
- "cabal_sha256": "2efc549644dd418bad537d1601fdd437c440d807265016bd993b6996c679ad2f",
- "component": "lib:os-string",
- "flags": [],
- "package": "os-string",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "339c35fd3a290522f23de4e33528423cfd0b0a8f22946b0b9816a817b926cba0",
- "version": "2.0.7"
- },
- {
- "cabal_sha256": "2f23146cbe0325029927b221647695a4c7d6e97548ff731110979e34361f58ef",
- "component": "lib:hashable",
- "flags": [
- "-arch-native",
- "-random-initial-seed"
- ],
- "package": "hashable",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "e58b3a8e18da5f6cd7e937e5fd683e500bb1f8276b3768269759119ca0cddb6a",
- "version": "1.5.0.0"
- },
- {
- "cabal_sha256": "b7648c6165729a973d95cb328f9fd874813a81c727707e8b2552b4f03399763b",
- "component": "lib:async",
- "flags": [
- "-bench"
- ],
- "package": "async",
- "revision": 3,
- "source": "hackage",
- "src_sha256": "1818473ebab9212afad2ed76297aefde5fae8b5d4404daf36939aece6a8f16f7",
- "version": "2.2.5"
- },
- {
- "cabal_sha256": "a694e88f9ec9fc79f0b03f233d3fea592b68f70a34aac2ddb5bcaecb6562e2fd",
- "component": "lib:base16-bytestring",
- "flags": [],
- "package": "base16-bytestring",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "1d5a91143ef0e22157536093ec8e59d226a68220ec89378d5dcaeea86472c784",
- "version": "1.0.2.0"
- },
- {
- "cabal_sha256": "45305ccf8914c66d385b518721472c7b8c858f1986945377f74f85c1e0d49803",
- "component": "lib:base64-bytestring",
- "flags": [],
- "package": "base64-bytestring",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "fbf8ed30edde271eb605352021431d8f1b055f95a56af31fe2eacf6bdfdc49c9",
- "version": "1.2.1.0"
- },
- {
- "cabal_sha256": "caa9b4a92abf1496c7f6a3c0f4e357426a54880077cb9f04e260a8bfa034b77b",
- "component": "lib:splitmix",
- "flags": [
- "-optimised-mixer"
- ],
- "package": "splitmix",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "9df07a9611ef45f1b1258a0b412f4d02c920248f69d2e2ce8ccda328f7e13002",
- "version": "0.1.0.5"
- },
- {
- "cabal_sha256": "32397de181e20ccaacf806ec70de9308cf044f089a2be37c936f3f8967bde867",
- "component": "lib:random",
- "flags": [],
- "package": "random",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "790f4dc2d2327c453ff6aac7bf15399fd123d55e927935f68f84b5df42d9a4b4",
- "version": "1.2.1.2"
- },
- {
- "cabal_sha256": "4d33a49cd383d50af090f1b888642d10116e43809f9da6023d9fc6f67d2656ee",
- "component": "lib:edit-distance",
- "flags": [],
- "package": "edit-distance",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "3e8885ee2f56ad4da940f043ae8f981ee2fe336b5e8e4ba3f7436cff4f526c4a",
- "version": "0.2.2.1"
- },
- {
- "cabal_sha256": null,
- "component": "lib:cabal-install-solver",
- "flags": [
- "-debug-expensive-assertions",
- "-debug-tracetree"
- ],
- "package": "cabal-install-solver",
- "revision": null,
- "source": "local",
- "src_sha256": null,
- "version": "3.15.0.0"
- },
- {
- "cabal_sha256": "acb64f2af52d81b0bb92c266f11d43def726a7a7b74a2c23d219e160b54edec7",
- "component": "lib:cryptohash-sha256",
- "flags": [
- "-exe",
- "+use-cbits"
- ],
- "package": "cryptohash-sha256",
- "revision": 5,
- "source": "hackage",
- "src_sha256": "73a7dc7163871a80837495039a099967b11f5c4fe70a118277842f7a713c6bf6",
- "version": "0.11.102.1"
- },
- {
- "cabal_sha256": "ccce771562c49a2b29a52046ca68c62179e97e8fbeacdae32ca84a85445e8f42",
- "component": "lib:echo",
- "flags": [
- "-example"
- ],
- "package": "echo",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "c9fe1bf2904825a65b667251ec644f197b71dc5c209d2d254be5de3d496b0e43",
- "version": "0.1.4"
- },
- {
- "cabal_sha256": "48383789821af5cc624498f3ee1d0939a070cda9468c0bfe63c951736be81c75",
- "component": "lib:ed25519",
- "flags": [
- "+no-donna",
- "+test-doctests",
- "+test-hlint",
- "+test-properties"
- ],
- "package": "ed25519",
- "revision": 8,
- "source": "hackage",
- "src_sha256": "d8a5958ebfa9309790efade64275dc5c441b568645c45ceed1b0c6ff36d6156d",
- "version": "0.0.5.0"
- },
- {
- "cabal_sha256": "8a3004c2de2a0b5ef0634d3da6eae62ba8d8a734bab9ed8c6cfd749e7ca08997",
- "component": "lib:lukko",
- "flags": [
- "+ofd-locking"
- ],
- "package": "lukko",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "72d86f8aa625b461f4397f737346f78a1700a7ffbff55cf6375c5e18916e986d",
- "version": "0.1.2"
- },
- {
- "cabal_sha256": "e9f151d9999be8953443e730524b2792e9c0a4fb5b1463097fa1a8230870fd8a",
- "component": "lib:tar-internal",
- "flags": [],
- "package": "tar",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "50bb660feec8a524416d6934251b996eaa7e39d49ae107ad505ab700d43f6814",
- "version": "0.6.3.0"
- },
- {
- "cabal_sha256": "e9f151d9999be8953443e730524b2792e9c0a4fb5b1463097fa1a8230870fd8a",
- "component": "lib:tar",
- "flags": [],
- "package": "tar",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "50bb660feec8a524416d6934251b996eaa7e39d49ae107ad505ab700d43f6814",
- "version": "0.6.3.0"
- },
- {
- "cabal_sha256": "85e64a75c0b490506a7edaa2d54950c668e66b65758bb08bb14cd31faf53a206",
- "component": "lib:zlib",
- "flags": [
- "-bundled-c-zlib",
- "+non-blocking-ffi",
- "+pkg-config"
- ],
- "package": "zlib",
- "revision": 2,
- "source": "hackage",
- "src_sha256": "6edd38b6b81df8d274952aa85affa6968ae86b2231e1d429ce8bc9083e6a55bc",
- "version": "0.7.1.0"
- },
- {
- "cabal_sha256": "a7311a70ce2cc820ee430c389f57f82a082f148230b37526c34eac72b7b3ff34",
- "component": "lib:hackage-security",
- "flags": [
- "+cabal-syntax",
- "+lukko"
- ],
- "package": "hackage-security",
- "revision": 4,
- "source": "hackage",
- "src_sha256": "2e4261576b3e11b9f5175392947f56a638cc1a3584b8acbb962b809d7c69db69",
- "version": "0.6.2.6"
- },
- {
- "cabal_sha256": "e4be4a206f5ab6ddb5ae4fbb39101529196e20af5670c5d33326fea6eff886fd",
- "component": "lib:open-browser",
- "flags": [],
- "package": "open-browser",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "0bed2e63800f738e78a4803ed22902accb50ac02068b96c17ce83a267244ca66",
- "version": "0.2.1.0"
- },
- {
- "cabal_sha256": "0322b2fcd1358f3355e0c8608efa60d27b14d1c9d476451dbcb9181363bd8b27",
- "component": "lib:regex-base",
- "flags": [],
- "package": "regex-base",
- "revision": 4,
- "source": "hackage",
- "src_sha256": "7b99408f580f5bb67a1c413e0bc735886608251331ad36322020f2169aea2ef1",
- "version": "0.94.0.2"
- },
- {
- "cabal_sha256": "816d6acc560cb86672f347a7bef8129578dde26ed760f9e79b4976ed9bd7b9fd",
- "component": "lib:regex-posix",
- "flags": [
- "-_regex-posix-clib"
- ],
- "package": "regex-posix",
- "revision": 3,
- "source": "hackage",
- "src_sha256": "c7827c391919227711e1cff0a762b1678fd8739f9c902fc183041ff34f59259c",
- "version": "0.96.0.1"
- },
- {
- "cabal_sha256": "3e196e1362e4d0ec9dfcd7f8d58b24fac91beafaa1c8ee34dc9dee489c362377",
- "component": "lib:resolv",
- "flags": [],
- "package": "resolv",
- "revision": 4,
- "source": "hackage",
- "src_sha256": "880d283df9132a7375fa28670f71e86480a4f49972256dc2a204c648274ae74b",
- "version": "0.2.0.2"
- },
- {
- "cabal_sha256": "8bb7261bd54bd58acfcb154be6a161fb6d0d31a1852aadc8e927d2ad2d7651d1",
- "component": "lib:safe-exceptions",
- "flags": [],
- "package": "safe-exceptions",
- "revision": 1,
- "source": "hackage",
- "src_sha256": "3c51d8d50c9b60ff8bf94f942fd92e3bea9e62c5afa778dfc9f707b79da41ef6",
- "version": "0.1.7.4"
- },
- {
- "cabal_sha256": "2de5218cef72b8ef090bd7d0fd930ffa143242a120c62e013b5cf039858f1855",
- "component": "lib:semaphore-compat",
- "flags": [],
- "package": "semaphore-compat",
- "revision": 3,
- "source": "hackage",
- "src_sha256": "1c6e6fab021c2ccee5d86112fb1c0bd016d15e0cf70c489dae5fb5ec156ed9e2",
- "version": "1.0.0"
- },
- {
- "cabal_sha256": null,
- "component": "lib:cabal-install",
- "flags": [
- "-git-rev",
- "+lukko",
- "+native-dns"
- ],
- "package": "cabal-install",
- "revision": null,
- "source": "local",
- "src_sha256": null,
- "version": "3.15.0.0"
- },
- {
- "cabal_sha256": null,
- "component": "exe:cabal",
- "flags": [
- "-git-rev",
- "+lukko",
- "+native-dns"
- ],
- "package": "cabal-install",
- "revision": null,
- "source": "local",
- "src_sha256": null,
- "version": "3.15.0.0"
- },
- {
- "cabal_sha256": "e4be4a206f5ab6ddb5ae4fbb39101529196e20af5670c5d33326fea6eff886fd",
- "component": "exe:example",
- "flags": [],
- "package": "open-browser",
- "revision": 0,
- "source": "hackage",
- "src_sha256": "0bed2e63800f738e78a4803ed22902accb50ac02068b96c17ce83a267244ca66",
- "version": "0.2.1.0"
- }
- ]
-}
diff --git a/bootstrap/linux-9.6.7.json b/bootstrap/linux-9.6.7.json
index 12eda9b8f19..2ae437086db 100644
--- a/bootstrap/linux-9.6.7.json
+++ b/bootstrap/linux-9.6.7.json
@@ -114,6 +114,18 @@
"src_sha256": null,
"version": "3.17.0.0"
},
+ {
+ "cabal_sha256": "9e9590572cc6bdb0d7ccb8835f7f9302f1c11a36c972a4c4a97aeb789be42cd9",
+ "component": "lib:process",
+ "flags": [
+ "-os-string"
+ ],
+ "package": "process",
+ "revision": 0,
+ "source": "hackage",
+ "src_sha256": "da03911abf6bbdc68342f8f25698b0d3780964ed591f1c7d7f9b688c1097fda1",
+ "version": "1.6.26.0"
+ },
{
"cabal_sha256": null,
"component": "lib:Cabal",
@@ -419,6 +431,16 @@
"src_sha256": "1def1a524cc894351e28e86a91cf2d043f18eeaba79070e1cc1304c9f79e4c17",
"version": "0.6.3.1"
},
+ {
+ "cabal_sha256": null,
+ "component": "lib:hooks-exe",
+ "flags": [],
+ "package": "hooks-exe",
+ "revision": null,
+ "source": "local",
+ "src_sha256": null,
+ "version": "0.1"
+ },
{
"cabal_sha256": "a5effff3d14a0bbfde51dd62e72cff069b56be4298f16a78db7d3cc0c678c859",
"component": "lib:open-browser",
diff --git a/bootstrap/linux-9.8.4.json b/bootstrap/linux-9.8.4.json
index 6d692ea80ca..eecb4e85dd9 100644
--- a/bootstrap/linux-9.8.4.json
+++ b/bootstrap/linux-9.8.4.json
@@ -431,6 +431,16 @@
"src_sha256": "1def1a524cc894351e28e86a91cf2d043f18eeaba79070e1cc1304c9f79e4c17",
"version": "0.6.3.1"
},
+ {
+ "cabal_sha256": null,
+ "component": "lib:hooks-exe",
+ "flags": [],
+ "package": "hooks-exe",
+ "revision": null,
+ "source": "local",
+ "src_sha256": null,
+ "version": "0.1"
+ },
{
"cabal_sha256": "a5effff3d14a0bbfde51dd62e72cff069b56be4298f16a78db7d3cc0c678c859",
"component": "lib:open-browser",
diff --git a/cabal-dev-scripts/cabal-dev-scripts.cabal b/cabal-dev-scripts/cabal-dev-scripts.cabal
index 92002387ee7..45f5b151739 100644
--- a/cabal-dev-scripts/cabal-dev-scripts.cabal
+++ b/cabal-dev-scripts/cabal-dev-scripts.cabal
@@ -18,7 +18,7 @@ executable gen-spdx
ghc-options: -Wall
build-depends:
, aeson ^>=2.2.3.0
- , base >=4.13 && <4.21
+ , base >=4.13 && <5
, bytestring
, containers
, Diff ^>=0.4
@@ -35,7 +35,7 @@ executable gen-spdx-exc
ghc-options: -Wall
build-depends:
, aeson ^>=2.2.3.0
- , base >=4.13 && <4.21
+ , base >=4.13 && <5
, bytestring
, containers
, Diff ^>=0.4
diff --git a/cabal-dev-scripts/src/GenPathsModule.hs b/cabal-dev-scripts/src/GenPathsModule.hs
index 7c5c947a5b7..19cc8874144 100644
--- a/cabal-dev-scripts/src/GenPathsModule.hs
+++ b/cabal-dev-scripts/src/GenPathsModule.hs
@@ -25,8 +25,6 @@ $(capture "decls" [d|
data Z = Z
{ zPackageName :: PackageName
, zVersionDigits :: String
- , zSupportsCpp :: Bool
- , zSupportsNoRebindableSyntax :: Bool
, zAbsolute :: Bool
, zRelocatable :: Bool
, zIsWindows :: Bool
diff --git a/cabal-dev-scripts/src/GenUtils.hs b/cabal-dev-scripts/src/GenUtils.hs
index 5751f99a1aa..0bf24c23d27 100644
--- a/cabal-dev-scripts/src/GenUtils.hs
+++ b/cabal-dev-scripts/src/GenUtils.hs
@@ -7,7 +7,6 @@ module GenUtils where
import Control.Lens (each, ix, (%~), (&))
import Data.Char (toUpper)
-import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import GHC.Generics (Generic)
diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal
index 5d5eaa37e5a..c769c22b506 100644
--- a/cabal-install-solver/cabal-install-solver.cabal
+++ b/cabal-install-solver/cabal-install-solver.cabal
@@ -95,7 +95,9 @@ library
Distribution.Solver.Types.SolverId
Distribution.Solver.Types.SolverPackage
Distribution.Solver.Types.SourcePackage
+ Distribution.Solver.Types.Stage
Distribution.Solver.Types.SummarizedMessage
+ Distribution.Solver.Types.Toolchain
Distribution.Solver.Types.Variable
build-depends:
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs
index edcca8e764d..a2ac44fcf44 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs
@@ -22,7 +22,7 @@ import Distribution.Compat.Graph
import Distribution.Compiler
( CompilerInfo )
import Distribution.Solver.Modular.Assignment
- ( Assignment, toCPs )
+ ( Assignment(..), toCPs )
import Distribution.Solver.Modular.ConfiguredConversion
( convCP )
import qualified Distribution.Solver.Modular.ConflictSet as CS
@@ -39,6 +39,8 @@ import Distribution.Solver.Modular.IndexConversion
( convPIs )
import Distribution.Solver.Modular.Log
( SolverFailure(..), displayLogMessages )
+import Distribution.Solver.Modular.Message
+ ( renderSummarizedMessage )
import Distribution.Solver.Modular.Package
( PN )
import Distribution.Solver.Modular.RetryLog
@@ -65,36 +67,36 @@ import Distribution.Solver.Types.Progress
( Progress(..), foldProgress )
import Distribution.Solver.Types.SummarizedMessage
( SummarizedMessage(StringMsg) )
-import Distribution.Solver.Types.Variable ( Variable(..) )
-import Distribution.System
- ( Platform(..) )
+import Distribution.Solver.Types.Variable
+ ( Variable(..) )
+import Distribution.Solver.Types.Toolchain
+
import Distribution.Simple.Setup
( BooleanFlag(..) )
import Distribution.Simple.Utils
( ordNubBy )
-import Distribution.Verbosity
-import Distribution.Solver.Modular.Message ( renderSummarizedMessage )
+import Distribution.Verbosity ( VerbosityLevel (..), normal, verbose )
-- | Ties the two worlds together: classic cabal-install vs. the modular
-- solver. Performs the necessary translations before and after.
modularResolver :: SolverConfig -> DependencyResolver loc
-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
- uncurry postprocess <$> -- convert install plan
- solve' sc cinfo idx pkgConfigDB pprefs gcs pns
- where
+modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do
+ (assignment, revdepmap) <- solve' sc cinfo pkgConfigDbs idx pprefs gcs pns
+
+ -- Results have to be converted into an install plan. 'convCP' removes
+ -- package qualifiers, which means that linked packages become duplicates
+ -- and can be removed.
+ return $ ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs assignment revdepmap)
+ where
+ cinfo = fst <$> toolchains
+
-- Indices have to be converted into solver-specific uniform index.
- idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
+ idx = convPIs toolchains gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
-- Constraints have to be converted into a finite map indexed by PN.
gcs = M.fromListWith (++) (map pair pcs)
where
pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])
- -- Results have to be converted into an install plan. 'convCP' removes
- -- package qualifiers, which means that linked packages become duplicates
- -- and can be removed.
- postprocess a rdm = ordNubBy nodeKey $
- map (convCP iidx sidx) (toCPs a rdm)
-
-- Helper function to extract the PN from a constraint.
pcName :: PackageConstraint -> PN
pcName (PackageConstraint scope _) = scopeToPackageName scope
@@ -133,21 +135,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
-- complete, i.e., it shows the whole chain of dependencies from the user
-- targets to the conflicting packages.
solve' :: SolverConfig
- -> CompilerInfo
+ -> Staged CompilerInfo
+ -> Staged (Maybe PkgConfigDb)
-> Index
- -> Maybe PkgConfigDb
-> (PN -> PackagePreferences)
-> Map PN [LabeledPackageConstraint]
-> Set PN
-> Progress SummarizedMessage String (Assignment, RevDepMap)
-solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
+solve' sc cinfo pkgConfigDb idx pprefs gcs pns =
toProgress $ retry (runSolver printFullLog sc) createErrorMsg
where
runSolver :: Bool -> SolverConfig
-> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap)
runSolver keepLog sc' =
displayLogMessages keepLog $
- solve sc' cinfo idx pkgConfigDB pprefs gcs pns
+ solve sc' cinfo pkgConfigDb idx pprefs gcs pns
createErrorMsg :: SolverFailure
-> RetryLog SummarizedMessage String (Assignment, RevDepMap)
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs
index cd4e7948819..63694b0b37c 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
+{-# LANGUAGE NamedFieldPuns #-}
module Distribution.Solver.Modular.Builder (
buildTree
, splits -- for testing
@@ -37,7 +36,8 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.ComponentDeps
import Distribution.Solver.Types.PackagePath
-import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.Settings (IndependentGoals (..))
+import qualified Distribution.Solver.Types.Stage as Stage
-- | All state needed to build and link the search tree. It has a type variable
-- because the linking phase doesn't need to know about the state used to build
@@ -64,41 +64,48 @@ type LinkingState = M.Map (PN, I) [PackagePath]
-- We also adjust the map of overall goals, and keep track of the
-- reverse dependencies of each of the goals.
extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
-extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
+extendOpen qpn deps buildState@(BS { rdeps = rdeps0, open = goals0 }) = go rdeps0 goals0 deps
where
go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
- go g o [] = s { rdeps = g, open = o }
- go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) =
- go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs
- -- Note: for 'Flagged' goals, we always insert, so later additions win.
- -- This is important, because in general, if a goal is inserted twice,
- -- the later addition will have better dependency information.
- go g o ((Stanza sn@(SN qpn _) t) : ngs) =
- go g (StanzaGoal sn t (flagGR qpn) : o) ngs
- go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs)
- | qpn == qpn' =
- -- We currently only add a self-dependency to the graph if it is
- -- between a package and its setup script. The edge creates a cycle
- -- and causes the solver to backtrack and choose a different
- -- instance for the setup script. We may need to track other
- -- self-dependencies once we implement component-based solving.
+ go rdeps goals [] =
+ buildState { rdeps = rdeps, open = goals }
+
+ go rdeps goals ((Flagged fn@(FN qpn' _) fInfo t f) : fdeps) =
+ go rdeps (FlagGoal fn fInfo t f (flagGR qpn') : goals) fdeps
+
+ -- Note: for 'Flagged' goals, we always insert, so later additions win.
+ -- This is important, because in general, if a goal is inserted twice,
+ -- the later addition will have better dependency information.
+ go rdeps goals ((Stanza sn@(SN qpn' _) t) : fdeps) =
+ go rdeps (StanzaGoal sn t (flagGR qpn') : goals) fdeps
+
+ go rdeps goals ((Simple (LDep dr (Dep (PkgComponent qpn' _) _)) c) : fdeps)
+ | qpn' == qpn =
+ -- We currently only add a self-dependency to the graph if it is
+ -- between a package and its setup script. The edge creates a cycle
+ -- and causes the solver to backtrack and choose a different
+ -- instance for the setup script. We may need to track other
+ -- self-dependencies once we implement component-based solving.
case c of
- ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs
- _ -> go g o ngs
- | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs
- | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs
- -- code above is correct; insert/adjust have different arg order
- go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs
- go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs
- go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs
+ ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn)) qpn' rdeps) goals fdeps
+ _ -> go rdeps goals fdeps
+ | qpn' `M.member` rdeps =
+ go (M.adjust (addIfAbsent (c, qpn)) qpn' rdeps) goals fdeps
+ | otherwise =
+ -- Note: insert/adjust have different arg order
+ go (M.insert qpn' [(c, qpn)] rdeps) (PkgGoal qpn' (DependencyGoal dr) : goals) fdeps
+
+ go rdeps o ((Simple (LDep _dr (Ext _ext )) _c) : goals) = go rdeps o goals
+ go rdeps o ((Simple (LDep _dr (Lang _lang)) _c) : goals) = go rdeps o goals
+ go rdeps o ((Simple (LDep _dr (Pkg _pn _vr)) _c) : goals) = go rdeps o goals
addIfAbsent :: Eq a => a -> [a] -> [a]
addIfAbsent x xs = if x `elem` xs then xs else x : xs
- -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by
- -- its containing package.
- flagGR :: qpn -> GoalReason qpn
- flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)
+-- GoalReason for a flag or stanza. Each flag/stanza is introduced only by
+-- its containing package.
+flagGR :: qpn -> GoalReason qpn
+flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)
-- | Given the current scope, qualify all the package names in the given set of
-- dependencies and then extend the set of open goals accordingly.
@@ -107,7 +114,7 @@ scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->
scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s
where
-- Qualify all package names
- qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps
+ qfdeps = qualifyDeps qpn fdeps
-- Introduce all package flags
qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs
-- Combine new package and flag goals
@@ -129,12 +136,14 @@ build = ana go
go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)
go s = addLinking (linkingState s) $ addChildren (buildState s)
+-- | Add children to the tree based on the current build state.
addChildren :: BuildState -> TreeF () QGoalReason BuildState
-- If we have a choice between many goals, we just record the choice in
-- the tree. We select each open goal in turn, and before we descend, remove
-- it from the queue of open goals.
addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })
+ -- No goals left. We have done.
| L.null gs = DoneF rdm ()
| otherwise = GoalChoiceF rdm $ P.fromList
$ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' }))
@@ -142,40 +151,42 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })
-- If we have already picked a goal, then the choice depends on the kind
-- of goal.
---
--- For a package, we look up the instances available in the global info,
--- and then handle each instance in turn.
-addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =
- case M.lookup pn idx of
- Nothing -> FailF
- (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)
- UnknownPackage
- Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->
- ([], POption i Nothing, bs { next = Instance qpn info }))
- (M.toList pis)))
- -- TODO: data structure conversion is rather ugly here
-
--- For a flag, we create only two subtrees, and we create them in the order
--- that is indicated by the flag default.
-addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =
- FChoiceF qfn rdm gr weak m b (W.fromList
- [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }),
- ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])
- where
- trivial = L.null t && L.null f
- weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
-
--- For a stanza, we also create only two subtrees. The order is initially
--- False, True. This can be changed later by constraints (force enabling
--- the stanza by replacing the False branch with failure) or preferences
--- (try enabling the stanza if possible by moving the True branch first).
-
-addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =
- SChoiceF qsn rdm gr trivial (W.fromList
- [([0], False, bs { next = Goals }),
- ([1], True, (extendOpen qpn t bs) { next = Goals })])
- where
- trivial = WeakOrTrivial (L.null t)
+addChildren bs@(BS { rdeps, index, next = OneGoal goal }) =
+ case goal of
+ PkgGoal qpn@(Q (PackagePath s _) pn) gr ->
+ -- For a package goal, we look up the instances available in the global
+ -- info, and then handle each instance in turn.
+ case M.lookup pn index of
+ Nothing -> FailF
+ (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)
+ UnknownPackage
+ Just pis -> PChoiceF qpn rdeps gr $ W.fromList
+ [ ([], POption i Nothing, bs { next = Instance qpn info })
+ | (i@(I s' _ver _loc), info) <- M.toList pis
+ -- Only instances belonging to the same stage are allowed.
+ , s == s'
+ ]
+ -- For a flag, we create only two subtrees, and we create them in the order
+ -- that is indicated by the flag default.
+ FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr ->
+ FChoiceF qfn rdeps gr weak m b $ W.fromList
+ [ ([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals })
+ , ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })
+ ]
+ where
+ trivial = L.null t && L.null f
+ weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
+ -- For a stanza, we also create only two subtrees. The order is initially
+ -- False, True. This can be changed later by constraints (force enabling
+ -- the stanza by replacing the False branch with failure) or preferences
+ -- (try enabling the stanza if possible by moving the True branch first).
+ StanzaGoal qsn@(SN qpn _) t gr ->
+ SChoiceF qsn rdeps gr trivial $ W.fromList
+ [ ([0], False, bs { next = Goals })
+ , ([1], True, (extendOpen qpn t bs) { next = Goals })
+ ]
+ where
+ trivial = WeakOrTrivial (L.null t)
-- For a particular instance, we change the state: we update the scope,
-- and furthermore we update the set of goals.
@@ -217,7 +228,7 @@ addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) =
addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)
-- The only nodes of interest are package nodes
addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =
- let linkedCs = fmap (\bs -> Linker bs ls) $
+ let linkedCs = fmap (`Linker` ls) $
W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)
unlinkedCs = W.mapWithKey goP cs
allCs = unlinkedCs `W.union` linkedCs
@@ -228,7 +239,7 @@ addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =
goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls
goP _ _ = alreadyLinked
in PChoiceF qpn rdm gr allCs
-addLinking ls t = fmap (\bs -> Linker bs ls) t
+addLinking ls t = fmap (`Linker` ls) t
linkChoices :: forall a w . LinkingState
-> QPN
@@ -254,18 +265,18 @@ buildTree idx (IndependentGoals ind) igs =
build Linker {
buildState = BS {
index = idx
- , rdeps = M.fromList (L.map (, []) qpns)
- , open = L.map topLevelGoal qpns
+ , rdeps = M.fromList [(qpn, []) | qpn <- qpns]
+ , open = [ PkgGoal qpn UserGoal | qpn <- qpns ]
, next = Goals
, qualifyOptions = defaultQualifyOptions idx
}
, linkingState = M.empty
}
where
- topLevelGoal qpn = PkgGoal qpn UserGoal
+ -- The package names are interpreted as top-level goals in the host stage.
+ path = PackagePath Stage.Host QualToplevel
+ qpns = [ Q path pn | pn <- igs ]
- qpns | ind = L.map makeIndependent igs
- | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs
{-------------------------------------------------------------------------------
Goals
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs
index 0e2e8ad5baa..af78f678712 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs
@@ -6,8 +6,6 @@ import Data.Maybe
import Prelude hiding (pi)
import Data.Either (partitionEithers)
-import Distribution.Package (UnitId, packageId)
-
import qualified Distribution.Simple.PackageIndex as SI
import Distribution.Solver.Modular.Configured
@@ -21,43 +19,47 @@ import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.InstSolverPackage
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Stage (Staged (..))
-- | Converts from the solver specific result @CP QPN@ into
-- a 'ResolverPackage', which can then be converted into
-- the install plan.
-convCP :: SI.InstalledPackageIndex ->
+convCP :: Staged SI.InstalledPackageIndex ->
CI.PackageIndex (SourcePackage loc) ->
CP QPN -> ResolverPackage loc
convCP iidx sidx (CP qpi fa es ds) =
- case convPI qpi of
- Left pi -> PreExisting $
+ case qpi of
+ -- Installed
+ (PI qpn (I s _ (Inst pi))) ->
+ PreExisting $
InstSolverPackage {
- instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,
+ instSolverStage = s,
+ instSolverQPN = qpn,
+ instSolverPkgIPI = fromMaybe (error "convCP: lookupUnitId failed") $ SI.lookupUnitId (getStage iidx s) pi,
instSolverPkgLibDeps = fmap fst ds',
instSolverPkgExeDeps = fmap snd ds'
}
- Right pi -> Configured $
+ -- "In repo" i.e. a source package
+ (PI qpn@(Q _path pn) (I s v (InRepo _pn))) ->
+ let pi = PackageIdentifier pn v in
+ Configured $
SolverPackage {
- solverPkgSource = srcpkg,
+ solverPkgStage = s,
+ solverPkgQPN = qpn,
+ solverPkgSource = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi,
solverPkgFlags = fa,
solverPkgStanzas = es,
solverPkgLibDeps = fmap fst ds',
solverPkgExeDeps = fmap snd ds'
}
- where
- srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi
where
ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})
ds' = fmap (partitionEithers . map convConfId) ds
-convPI :: PI QPN -> Either UnitId PackageId
-convPI (PI _ (I _ (Inst pi))) = Left pi
-convPI pi = Right (packageId (either id id (convConfId pi)))
-
convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}
-convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
+convConfId (PI (Q (PackagePath _stage q) pn) (I stage v loc)) =
case loc of
- Inst pi -> Left (PreExistingId sourceId pi)
+ Inst pi -> Left (PreExistingId stage sourceId pi)
_otherwise
| QualExe _ pn' <- q
-- NB: the dependencies of the executable are also
@@ -66,7 +68,7 @@ convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
-- at the actual thing. Fortunately for us, I was
-- silly and didn't allow arbitrarily nested build-tools
-- dependencies, so a shallow check works.
- , pn == pn' -> Right (PlannedId sourceId)
- | otherwise -> Left (PlannedId sourceId)
+ , pn == pn' -> Right (PlannedId stage sourceId)
+ | otherwise -> Left (PlannedId stage sourceId)
where
sourceId = PackageIdentifier pn v
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs
index b82e39a0d26..4ddf93a9a38 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs
@@ -15,6 +15,7 @@ import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.ComponentDeps (Component)
import Distribution.Solver.Types.PackagePath
+import GHC.Stack (HasCallStack)
-- | Find and reject any nodes with cyclic dependencies
detectCyclesPhase :: Tree d c -> Tree d c
@@ -23,11 +24,11 @@ detectCyclesPhase = go
-- Only check children of choice nodes.
go :: Tree d c -> Tree d c
go (PChoice qpn rdm gr cs) =
- PChoice qpn rdm gr $ fmap (checkChild qpn) (fmap go cs)
+ PChoice qpn rdm gr $ fmap (checkChild qpn . go) cs
go (FChoice qfn@(FN qpn _) rdm gr w m d cs) =
- FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs)
+ FChoice qfn rdm gr w m d $ fmap (checkChild qpn . go) cs
go (SChoice qsn@(SN qpn _) rdm gr w cs) =
- SChoice qsn rdm gr w $ fmap (checkChild qpn) (fmap go cs)
+ SChoice qsn rdm gr w $ fmap (checkChild qpn . go) cs
go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs)
go x@(Fail _ _) = x
go x@(Done _ _) = x
@@ -51,7 +52,7 @@ detectCyclesPhase = go
-- all decisions that could potentially break the cycle.
--
-- TODO: The conflict set should also contain flag and stanza variables.
-findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
+findCycles :: HasCallStack => QPN -> RevDepMap -> Maybe ConflictSet
findCycles pkg rdm =
-- This function has two parts: a faster cycle check that is called at every
-- step and a slower calculation of the conflict set.
@@ -115,6 +116,6 @@ instance G.IsNode RevDepMapNode where
nodeKey (RevDepMapNode qpn _) = qpn
nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns
-revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
+revDepMapToGraph :: HasCallStack => RevDepMap -> G.Graph RevDepMapNode
revDepMapToGraph rdm = G.fromDistinctList
[RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs
index 5db05360a51..1a3783fe6ba 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs
@@ -58,6 +58,7 @@ import Distribution.Solver.Types.PackagePath
import Distribution.Types.LibraryName
import Distribution.Types.PkgconfigVersionRange
import Distribution.Types.UnqualComponentName
+import Distribution.Solver.Types.Stage
{-------------------------------------------------------------------------------
Constrained instances
@@ -85,14 +86,37 @@ type FlaggedDeps qpn = [FlaggedDep qpn]
-- | Flagged dependencies can either be plain dependency constraints,
-- or flag-dependent dependency trees.
-data FlaggedDep qpn =
- -- | Dependencies which are conditional on a flag choice.
- Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
- -- | Dependencies which are conditional on whether or not a stanza
+--
+-- Note: this is a recursive data structure representing a tree of dependencies.
+--
+-- Note 2: why LDep contains its own DependencyReason? I am thinking it should
+-- be external to this type. Basically you traverse the tree and the flag and
+-- stanza choices are the DepedencyReason?
+data FlaggedDep qpn
+ = -- | Dependencies which are conditional on a flag choice.
+ Flagged
+ (FN qpn)
+ -- ^ The qualified flag name.
+ FInfo
+ -- ^ The flag information.
+ (FlaggedDeps qpn)
+ -- ^ Extra dependencies when the flag is true.
+ (FlaggedDeps qpn)
+ -- ^ Extra dependencies when the flag is false.
+ | -- | Dependencies which are conditional on whether or not a stanza.
-- (e.g., a test suite or benchmark) is enabled.
- | Stanza (SN qpn) (TrueFlaggedDeps qpn)
- -- | Dependencies which are always enabled, for the component 'comp'.
- | Simple (LDep qpn) Component
+ Stanza
+ (SN qpn)
+ -- ^ The qualified stanza name.
+ (FlaggedDeps qpn)
+ -- ^ Extra dependencies when stanza is enabled.
+ | -- | Dependencies which are always enabled.
+ Simple
+ (LDep qpn)
+ -- ^ The dependency.
+ Component
+ -- ^ The component of `qpn` introducing the dependency.
+ deriving Show
-- | Conservatively flatten out flagged dependencies
--
@@ -105,43 +129,65 @@ flattenFlaggedDeps = concatMap aux
aux (Stanza _ t) = flattenFlaggedDeps t
aux (Simple d c) = [(d, c)]
-type TrueFlaggedDeps qpn = FlaggedDeps qpn
-type FalseFlaggedDeps qpn = FlaggedDeps qpn
-
-- | A 'Dep' labeled with the reason it was introduced.
--
-- 'LDep' intentionally has no 'Functor' instance because the type variable
-- is used both to record the dependencies as well as who's doing the
-- depending; having a 'Functor' instance makes bugs where we don't distinguish
-- these two far too likely. (By rights 'LDep' ought to have two type variables.)
-data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)
+data LDep qpn
+ = LDep
+ (DependencyReason qpn)
+ -- ^ The reason the dependency was introduced.
+ (Dep qpn)
+ -- ^ The dependency itself.
+ deriving Show
-- | A dependency (constraint) associates a package name with a constrained
-- instance. It can also represent other types of dependencies, such as
-- dependencies on language extensions.
-data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component
- | Ext Extension -- ^ dependency on a language extension
- | Lang Language -- ^ dependency on a language version
- | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package
- deriving Functor
+data Dep qpn
+ = -- | dependency on a package component
+ Dep (PkgComponent qpn) CI
+ | -- | dependency on a language extension
+ Ext Extension
+ | -- | dependency on a language version
+ Lang Language
+ | -- | dependency on a pkg-config package
+ Pkg PkgconfigName PkgconfigVersionRange
+ deriving (Functor, Show)
-- | An exposed component within a package. This type is used to represent
-- build-depends and build-tool-depends dependencies.
-data PkgComponent qpn = PkgComponent qpn ExposedComponent
+data PkgComponent qpn
+ = PkgComponent
+ qpn
+ -- ^ The qualified name of the package.
+ ExposedComponent
+ -- ^ The component exposed by the package.
deriving (Eq, Ord, Functor, Show)
-- | A component that can be depended upon by another package, i.e., a library
-- or an executable.
-data ExposedComponent =
+data ExposedComponent
+ = -- | A library component
ExposedLib LibraryName
- | ExposedExe UnqualComponentName
+ | -- | An executable component
+ ExposedExe UnqualComponentName
deriving (Eq, Ord, Show)
-- | The reason that a dependency is active. It identifies the package and any
-- flag and stanza choices that introduced the dependency. It contains
-- everything needed for creating ConflictSets or describing conflicts in solver
-- log messages.
-data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)
+data DependencyReason qpn
+ = DependencyReason
+ qpn
+ -- ^ The qualified name of the dependent package.
+ (Map Flag FlagValue)
+ -- ^ The flag choices that introduced the dependency.
+ (S.Set Stanza)
+ -- ^ The stanza choices that introduced the dependency.
deriving (Functor, Eq, Show)
-- | Print the reason that a dependency was introduced.
@@ -150,7 +196,7 @@ showDependencyReason (DependencyReason qpn flags stanzas) =
unwords $
showQPN qpn
: map (uncurry showFlagValue) (M.toList flags)
- ++ map (\s -> showSBool s True) (S.toList stanzas)
+ ++ map (`showSBool` True) (S.toList stanzas)
-- | Options for goal qualification (used in 'qualifyDeps')
--
@@ -174,8 +220,8 @@ data QualifyOptions = QO {
--
-- NOTE: It's the _dependencies_ of a package that may or may not be independent
-- from the package itself. Package flag choices must of course be consistent.
-qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN
-qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
+qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN
+qualifyDeps (Q pp@(PackagePath s q) pn) = go
where
go :: FlaggedDeps PN -> FlaggedDeps QPN
go = map go1
@@ -197,37 +243,20 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp)
goD :: Dep PN -> Component -> Dep QPN
- goD (Ext ext) _ = Ext ext
- goD (Lang lang) _ = Lang lang
- goD (Pkg pkn vr) _ = Pkg pkn vr
- goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =
- Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci
- goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp
- | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci
- | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci
- | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci
-
- -- If P has a setup dependency on Q, and Q has a regular dependency on R, then
- -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
- -- dependency on R. We do not do this for the base qualifier however.
- --
- -- The inherited qualifier is only used for regular dependencies; for setup
- -- and base dependencies we override the existing qualifier. See #3160 for
- -- a detailed discussion.
- inheritedQ :: Qualifier
- inheritedQ = case q of
- QualSetup _ -> q
- QualExe _ _ -> q
- QualToplevel -> q
- QualBase _ -> QualToplevel
-
- -- Should we qualify this goal with the 'Base' package path?
- qBase :: PN -> Bool
- qBase dep = qoBaseShim && unPackageName dep == "base"
-
- -- Should we qualify this goal with the 'Setup' package path?
- qSetup :: Component -> Bool
- qSetup comp = qoSetupIndependent && comp == ComponentSetup
+ goD (Ext ext) _ = Ext ext
+ goD (Lang lang) _ = Lang lang
+ goD (Pkg pkn vr) _ = Pkg pkn vr
+
+ -- In case of executable and setup dependencies, we need to qualify the dependency
+ -- with the previsous stage (e.g. Host -> Build).
+ goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _component =
+ Dep (Q (PackagePath (prevStage s) (QualExe pn qpn)) <$> dep) ci
+
+ goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) ComponentSetup =
+ Dep (Q (PackagePath (prevStage s) (QualSetup pn)) <$> dep) ci
+
+ goD (Dep dep@(PkgComponent _qpn _) ci) _component =
+ Dep (Q (PackagePath s q) <$> dep) ci
-- | Remove qualifiers from set of dependencies
--
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs
index 90038a28f5c..5aa9b52c14e 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs
@@ -194,7 +194,7 @@ assign tree = go tree (A M.empty M.empty M.empty)
where f k r = r (A pa (M.insert qfn k fa) sa)
go (SChoice qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f (fmap go ts)
where f k r = r (A pa fa (M.insert qsn k sa))
- go (GoalChoice rdm ts) a = GoalChoice rdm $ fmap ($ a) (fmap go ts)
+ go (GoalChoice rdm ts) a = GoalChoice rdm $ fmap (`go` a) ts
-- | A tree traversal that simultaneously propagates conflict sets up
-- the tree from the leaves and creates a log.
@@ -268,9 +268,9 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx
-- Skipping it is an optimization. If false, it returns a new conflict set
-- to be merged with the previous one.
couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet
- couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =
+ couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _stage v _) _) conflicts =
let (PInfo deps _ _ _) = idx M.! pn M.! i
- qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps
+ qdeps = qualifyDeps currentQPN deps
couldBeResolved :: CS.Conflict -> Maybe ConflictSet
couldBeResolved CS.OtherConflict = Nothing
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs
index 2f28d12de85..b0b576205ef 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs
@@ -32,10 +32,15 @@ type Index = Map PN (Map I PInfo)
-- globally, for reasons external to the solver. We currently use this
-- for shadowing which essentially is a GHC limitation, and for
-- installed packages that are broken.
-data PInfo = PInfo (FlaggedDeps PN)
- (Map ExposedComponent ComponentInfo)
- FlagInfo
- (Maybe FailReason)
+data PInfo = PInfo
+ (FlaggedDeps PN)
+ -- ^ The package dependencies, whether they are conditional on a flag, a
+ -- stanza or always active.
+ (Map ExposedComponent ComponentInfo)
+ -- ^ Info associated with each library and executable component.
+ FlagInfo
+ --
+ (Maybe FailReason)
-- | Info associated with each library and executable in a package instance.
data ComponentInfo = ComponentInfo {
@@ -64,7 +69,7 @@ defaultQualifyOptions idx = QO {
| -- Find all versions of base ..
Just is <- [M.lookup base idx]
-- .. which are installed ..
- , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is
+ , (I _ _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is
-- .. and flatten all their dependencies ..
, (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps
]
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
index 72d0b8193e3..4844909123c 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs
@@ -34,6 +34,7 @@ import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackageIndex as CI
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Stage (Stage(..), Staged(..), stages)
import Distribution.Solver.Modular.Dependency as D
import Distribution.Solver.Modular.Flag as F
@@ -42,6 +43,9 @@ import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Modular.Version
+import qualified Distribution.Compat.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
+
-- | Convert both the installed package index and the source package
-- index into one uniform solver index.
--
@@ -53,24 +57,31 @@ import Distribution.Solver.Modular.Version
-- resolving these situations. However, the right thing to do is to
-- fix the problem there, so for now, shadowing is only activated if
-- explicitly requested.
-convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
- -> ShadowPkgs -> StrongFlags -> SolveExecutables
- -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
- -> Index
-convPIs os arch comp constraints sip strfl solveExes iidx sidx =
+convPIs
+ :: Staged (CompilerInfo, Platform)
+ -> Map PN [LabeledPackageConstraint]
+ -> ShadowPkgs
+ -> StrongFlags
+ -> SolveExecutables
+ -> Staged SI.InstalledPackageIndex
+ -> CI.PackageIndex (SourcePackage loc)
+ -> Index
+convPIs toolchains' constraints sip strfl solveExes iidx sidx =
mkIndex $
- convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx
+ convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx
-- | Convert a Cabal installed package index to the simpler,
-- more uniform index format of the solver.
-convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]
-convIPI' (ShadowPkgs sip) idx =
+convIPI' :: ShadowPkgs -> Staged SI.InstalledPackageIndex -> [(PN, I, PInfo)]
+convIPI' (ShadowPkgs sip) sipi =
-- apply shadowing whenever there are multiple installed packages with
-- the same version
- [ maybeShadow (convIP idx pkg)
+ [ maybeShadow (convIP stage idx pkg)
-- IMPORTANT to get internal libraries. See
-- Note [Index conversion with internal libraries]
- | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx
+ | stage <- stages
+ , let idx = getStage sipi stage
+ , (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx
, (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]
where
@@ -80,16 +91,16 @@ convIPI' (ShadowPkgs sip) idx =
shadow x = x
-- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.
-convId :: IPI.InstalledPackageInfo -> (PN, I)
-convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)
+convId :: Stage -> IPI.InstalledPackageInfo -> (PN, I)
+convId stage ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi)
where MungedPackageId mpn ver = mungedId ipi
-- HACK. See Note [Index conversion with internal libraries]
pn = encodeCompatPackageName mpn
-- | Convert a single installed package into the solver-specific format.
-convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
-convIP idx ipi =
- case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
+convIP :: Stage -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)
+convIP stage idx ipi =
+ case traverse (convIPId stage (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of
Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))
Right fds -> (pn, i, PInfo fds components M.empty Nothing)
where
@@ -101,7 +112,7 @@ convIP idx ipi =
, compIsBuildable = IsBuildable True
}
- (pn, i) = convId ipi
+ (pn, i) = convId stage ipi
-- 'sourceLibName' is unreliable, but for now we only really use this for
-- primary libs anyways
@@ -141,48 +152,61 @@ convIP idx ipi =
-- May return Nothing if the package can't be found in the index. That
-- indicates that the original package having this dependency is broken
-- and should be ignored.
-convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
-convIPId dr comp idx ipid =
+convIPId :: Stage -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)
+convIPId stage dr comp idx ipid =
case SI.lookupUnitId idx ipid of
Nothing -> Left ipid
- Just ipi -> let (pn, i) = convId ipi
- name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
+ Just ipi -> let (pn, i) = convId stage ipi
+ name = ExposedLib LMainLibName -- TODO: Handle sub-libraries.
in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)
-- NB: something we pick up from the
-- InstalledPackageIndex is NEVER an executable
-- | Convert a cabal-install source package index to the simpler,
-- more uniform index format of the solver.
-convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
- -> StrongFlags -> SolveExecutables
- -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
-convSPI' os arch cinfo constraints strfl solveExes =
- L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
+-- NOTE: The package description of source package can depent on the platform
+-- and compiler version. Here we decide to convert a single source package
+-- into multiple index entries, one for each stage, where the conditionals are
+-- resolved. This choice might incour in high memory consumption and it might
+-- be worth looking for a different approach.
+convSPI'
+ :: Staged (CompilerInfo, Platform)
+ -> Map PN [LabeledPackageConstraint]
+ -> StrongFlags
+ -> SolveExecutables
+ -> CI.PackageIndex (SourcePackage loc)
+ -> [(PN, I, PInfo)]
+convSPI' toolchains constraints strfl solveExes sidx =
+ concat $
+ [ map (convSP stage os arch cinfo constraints strfl solveExes) (CI.allPackages sidx)
+ | stage <- stages
+ , let (cinfo, Platform arch os) = getStage toolchains stage
+ ]
-- | Convert a single source package into the solver-specific format.
-convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+convSP :: Stage -> OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
-> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
-convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
- let i = I pv InRepo
+convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
+ let i = I stage pv (InRepo pn)
pkgConstraints = fromMaybe [] $ M.lookup pn constraints
- in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)
+ in (pn, i, convGPD stage os arch cinfo pkgConstraints strfl solveExes pn gpd)
-- We do not use 'flattenPackageDescription' or 'finalizePD'
-- from 'Distribution.PackageDescription.Configuration' here, because we
-- want to keep the condition tree, but simplify much of the test.
-- | Convert a generic package description to a solver-specific 'PInfo'.
-convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]
+convGPD :: Stage -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]
-> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription
-> PInfo
-convGPD os arch cinfo constraints strfl solveExes pn
+convGPD stage os arch cinfo constraints strfl solveExes pn
(GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) =
let
fds = flagInfo strfl flags
conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->
- CondTree ConfVar [Dependency] a -> FlaggedDeps PN
+ CondTree ConfVar a -> FlaggedDeps PN
conv comp getInfo dr =
convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes .
addBuildableCondition getInfo
@@ -233,7 +257,7 @@ convGPD os arch cinfo constraints strfl solveExes pn
, compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False
}
- testCondition = testConditionForComponent os arch cinfo constraints
+ testCondition = testConditionForComponent stage os arch cinfo constraints
isPrivate LibraryVisibilityPrivate = True
isPrivate LibraryVisibilityPublic = False
@@ -246,24 +270,27 @@ convGPD os arch cinfo constraints strfl solveExes pn
-- before dependency solving. Additionally, this function only considers flags
-- that are set by unqualified flag constraints, and it doesn't check the
-- intra-package dependencies of a component.
-testConditionForComponent :: OS
+testConditionForComponent :: Stage
+ -> OS
-> Arch
-> CompilerInfo
-> [LabeledPackageConstraint]
-> (a -> Bool)
- -> CondTree ConfVar [Dependency] a
+ -> CondTree ConfVar a
-> Maybe Bool
-testConditionForComponent os arch cinfo constraints p tree =
+testConditionForComponent stage os arch cinfo constraints p tree =
case go $ extractCondition p tree of
Lit True -> Just True
Lit False -> Just False
_ -> Nothing
where
+ -- TODO: fix for stage
flagAssignment :: [(FlagName, Bool)]
flagAssignment =
mconcat [ unFlagAssignment fa
- | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)
- <- L.map unlabelPackageConstraint constraints]
+ | PackageConstraint (ConstraintScope stage' (ScopeAnyQualifier _)) (PackagePropertyFlags fa)
+ <- L.map unlabelPackageConstraint constraints
+ , maybe True (== stage) stage']
-- Simplify the condition, using the current environment. Most of this
-- function was copied from convBranch and
@@ -329,8 +356,8 @@ convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -
Component ->
(a -> BuildInfo) ->
SolveExecutables ->
- CondTree ConfVar [Dependency] a -> FlaggedDeps PN
-convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =
+ CondTree ConfVar a -> FlaggedDeps PN
+convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info branches) =
-- Merge all library and build-tool dependencies at every level in
-- the tree of flagged dependencies. Otherwise 'extractCommon'
-- could create duplicate dependencies, and the number of
@@ -338,7 +365,7 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExec
-- of the tree.
mergeSimpleDeps $
[ D.Simple singleDep comp
- | dep <- ds
+ | dep <- L.view (L.targetBuildDepends) (getInfo info)
, singleDep <- convLibDeps dr dep ] -- unconditional package dependencies
++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies
@@ -461,7 +488,7 @@ convBranch :: Map FlagName Bool
-> Component
-> (a -> BuildInfo)
-> SolveExecutables
- -> CondBranch ConfVar [Dependency] a
+ -> CondBranch ConfVar a
-> FlaggedDeps PN
convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') =
go c'
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs
index e14c0751de4..3ea4f5fd5a6 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs
@@ -101,7 +101,7 @@ validateLinking index = (`runReader` initVS) . go
goP qpn@(Q _pp pn) opt@(POption i _) r = do
vs <- ask
let PInfo deps _ _ _ = vsIndex vs ! pn ! i
- qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
+ qdeps = qualifyDeps qpn deps
newSaved = M.insert qpn qdeps (vsSaved vs)
case execUpdateState (pickPOption qpn opt qdeps) vs of
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
@@ -276,7 +276,7 @@ linkDeps target = \deps -> do
requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
requalify deps = do
vs <- get
- return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)
+ return $ qualifyDeps target (unqualifyDeps deps)
pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag qfn b = do
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
index 5dbcce9194c..d378c732821 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -34,7 +34,7 @@ import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.MessageUtils
( showUnsupportedExtension, showUnsupportedLanguage )
import Distribution.Solver.Modular.Package
- ( PI(PI), showI, showPI )
+ ( showI )
import Distribution.Solver.Modular.Tree
( FailReason(..), POption(..), ConflictingDep(..) )
import Distribution.Solver.Modular.Version
@@ -262,8 +262,8 @@ data MergedPackageConflict = MergedPackageConflict {
showOption :: QPN -> POption -> String
showOption qpn@(Q _pp pn) (POption i linkedTo) =
case linkedTo of
- Nothing -> showPI (PI qpn i) -- Consistent with prior to POption
- Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)
+ Nothing -> showQPN qpn ++ " == " ++ showI i
+ Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn
-- | Shows a mixed list of instances and versions in a human-friendly way,
-- abbreviated.
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs
index 876ac2d790c..922020b745b 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs
@@ -11,7 +11,6 @@ module Distribution.Solver.Modular.Package
, QPV
, instI
, instUid
- , makeIndependent
, primaryPP
, setupPP
, showI
@@ -27,6 +26,7 @@ import Distribution.Pretty (prettyShow)
import Distribution.Solver.Modular.Version
import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.Stage (Stage, showStage)
-- | A package name.
type PN = PackageName
@@ -49,22 +49,17 @@ type PId = UnitId
-- package instance via its 'PId'.
--
-- TODO: More information is needed about the repo.
-data Loc = Inst PId | InRepo
+data Loc = Inst PId | InRepo PackageName
deriving (Eq, Ord, Show)
-- | Instance. A version number and a location.
-data I = I Ver Loc
+data I = I Stage Ver Loc
deriving (Eq, Ord, Show)
-- | String representation of an instance.
showI :: I -> String
-showI (I v InRepo) = showVer v
-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid
- where
- extractPackageAbiHash xs =
- case first reverse $ break (=='-') $ reverse (prettyShow xs) of
- (ys, []) -> ys
- (ys, _) -> '-' : ys
+showI (I s v (InRepo pn)) = intercalate ":" [showStage s, "source", prettyShow (PackageIdentifier pn v)]
+showI (I s _v (Inst uid)) = intercalate ":" [showStage s, "installed", prettyShow uid]
-- | Package instance. A package name and an instance.
data PI qpn = PI qpn I
@@ -75,11 +70,11 @@ showPI :: PI QPN -> String
showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i
instI :: I -> Bool
-instI (I _ (Inst _)) = True
+instI (I _ _ (Inst _)) = True
instI _ = False
instUid :: UnitId -> I -> Bool
-instUid uid (I _ (Inst uid')) = uid == uid'
+instUid uid (I _ _ (Inst uid')) = uid == uid'
instUid _ _ = False
-- | Is the package in the primary group of packages. This is used to
@@ -105,7 +100,3 @@ setupPP :: PackagePath -> Bool
setupPP (PackagePath _ns (QualSetup _)) = True
setupPP (PackagePath _ns _) = False
--- | Qualify a target package with its own name so that its dependencies are not
--- required to be consistent with other targets.
-makeIndependent :: PN -> QPN
-makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
index e33eb09524f..9dad77e15f3 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
@@ -72,7 +72,7 @@ addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c
addWeight f = addWeights [f]
version :: POption -> Ver
-version (POption (I v _) _) = v
+version (POption (I _ v _) _) = v
-- | Prefer to link packages whenever possible.
preferLinked :: EndoTreeTrav d c
@@ -139,7 +139,7 @@ preferPackagePreferences pcs =
-- Prefer installed packages over non-installed packages.
installed :: POption -> Weight
- installed (POption (I _ (Inst _)) _) = 0
+ installed (POption (I _ _ (Inst _)) _) = 0
installed _ = 1
-- | Traversal that tries to establish package stanza enable\/disable
@@ -184,7 +184,7 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s
else r
where
go :: I -> PackageProperty -> Tree d c
- go (I v _) (PackagePropertyVersion vr)
+ go (I _ v _) (PackagePropertyVersion vr)
| checkVR vr v = r
| otherwise = Fail c (GlobalConstraintVersion vr src)
go _ PackagePropertyInstalled
@@ -341,10 +341,10 @@ avoidReinstalls p = go
| otherwise = PChoiceF qpn rdm gr cs
where
disableReinstalls =
- let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]
+ let installed = [ v | (_, POption (I _ v (Inst _)) _, _) <- W.toList cs ]
in W.mapWithKey (notReinstall installed) cs
- notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =
+ notReinstall vs (POption (I _ v (InRepo _pn)) _) _ | v `elem` vs =
Fail (varToConflictSet (P qpn)) CannotReinstall
notReinstall _ _ x =
x
@@ -423,9 +423,9 @@ deferSetupExeChoices = go
go x = x
noSetupOrExe :: Goal QPN -> Bool
- noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False
- noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False
- noSetupOrExe _ = True
+ noSetupOrExe (Goal (P (Q (PackagePath _ (QualSetup _)) _)) _) = False
+ noSetupOrExe (Goal (P (Q (PackagePath _ (QualExe _ _)) _)) _) = False
+ noSetupOrExe _ = True
-- | Transformation that tries to avoid making weak flag choices early.
-- Weak flags are trivial flags (not influencing dependencies) or such
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
index d16fb37af37..71e7611fbac 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
@@ -44,11 +44,12 @@ import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.PSQ as PSQ
import Distribution.Simple.Setup (BooleanFlag(..))
+import Distribution.Solver.Types.Stage (Staged, Stage(..))
#ifdef DEBUG_TRACETREE
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W
-import qualified Distribution.Deprecated.Text as T
+import Distribution.Solver.Modular.Version (showVer)
import Debug.Trace.Tree (gtraceJson)
import Debug.Trace.Tree.Simple
@@ -89,14 +90,14 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
-- before exploration.
--
solve :: SolverConfig -- ^ solver parameters
- -> CompilerInfo
+ -> Staged CompilerInfo
+ -> Staged (Maybe PkgConfigDb)
-> Index -- ^ all available packages as an index
- -> Maybe PkgConfigDb -- ^ available pkg-config pkgs
-> (PN -> PackagePreferences) -- ^ preferences
-> M.Map PN [LabeledPackageConstraint] -- ^ global constraints
-> S.Set PN -- ^ global goals
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
+solve sc cinfo pkgConfigDB idx userPrefs userConstraints userGoals =
explorePhase .
traceTree "cycles.json" id .
detectCycles .
@@ -137,7 +138,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
P.enforceManualFlags userConstraints
validationCata = P.enforceSingleInstanceRestriction .
validateLinking idx .
- validateTree cinfo idx pkgConfigDB
+ validateTree cinfo pkgConfigDB idx
prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
(case onlyConstrained sc of
OnlyConstrainedAll ->
@@ -203,7 +204,7 @@ instance GSimpleTree (Tree d c) where
-- Show package choice
goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)
- goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree)
+ goP _ (POption (I _stage ver _loc) Nothing) subtree = (showVer ver, go subtree)
goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree)
-- Show flag or stanza choice
@@ -250,5 +251,5 @@ _removeGR = trav go
dummy =
DependencyGoal $
DependencyReason
- (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))
+ (Q (PackagePath Host QualToplevel) (mkPackageName "$"))
M.empty S.empty
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs
index a845ad6ef9d..169b33de499 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs
@@ -49,19 +49,52 @@ type Weight = Double
--
-- TODO: The weight type should be changed from [Double] to Double to avoid
-- giving too much weight to preferences that are applied later.
-data Tree d c =
- -- | Choose a version for a package (or choose to link)
- PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c))
+--
+-- Note: this the tree *of possible choices*, which is used to explore all
+-- possible solutions to a given problem. It does not describe a single solution.
+data Tree d c
+ = -- | Choose a version for a package (or choose to link)
+ PChoice
+ QPN
+ -- ^ The package to choose an instance for
+ RevDepMap
+ -- ^ The reverse dependency map (FIXME ?)
+ c
+ -- ^ Additional data for the choice node
+ (WeightedPSQ [Weight] POption (Tree d c))
+ -- ^ Weighted list of possible options (`POption`) paired with the subsequent search tree.
- -- | Choose a value for a flag
- --
- -- The Bool is the default value.
- | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c))
+ | -- | Choose a value for a flag.
+ FChoice
+ QFN
+ -- ^ The flag to choose a value for.
+ RevDepMap
+ -- ^ The reverse dependency map (FIXME ?).
+ c
+ -- ^ Additional data for the choice node.
+ WeakOrTrivial
+ -- ^ Whether the choice should be deferred.
+ FlagType
+ -- ^ Whether the flag is manual or automatic.
+ Bool
+ -- ^ The flag default value
+ (WeightedPSQ [Weight] Bool (Tree d c))
+ -- ^ Weighted list of possible options paired with the subsequent search tree.
- -- | Choose whether or not to enable a stanza
- | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))
+ | -- | Choose whether or not to enable a stanza.
+ SChoice
+ QSN
+ -- ^ The stanza to choose to enable or disable.
+ RevDepMap
+ -- ^ The reverse dependency map (FIXME ?).
+ c
+ -- ^ Additional data for the choice node.
+ WeakOrTrivial
+ -- ^ Whether the choice should be deferred.
+ (WeightedPSQ [Weight] Bool (Tree d c))
+ -- ^ Weighted list of possible options paired with the subsequent search tree.
- -- | Choose which choice to make next
+ | -- | Choose which choice to make next
--
-- Invariants:
--
@@ -72,13 +105,25 @@ data Tree d c =
-- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice'
-- or 'SChoice' directly below a 'GoalChoice' node must equal the reason
-- recorded on that 'GoalChoice' node.
- | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c))
+ GoalChoice
+ RevDepMap
+ -- ^ The reverse dependency map (FIXME ?).
+ (PSQ (Goal QPN) (Tree d c))
+ -- ^ Priority search queue associating a goal with the search tree.
- -- | We're done -- we found a solution!
- | Done RevDepMap d
+ | -- | We're done -- we found a solution!
+ Done
+ RevDepMap
+ -- ^ The reverse dependency map (FIXME ?).
+ d
+ -- ^ The solution.
- -- | We failed to find a solution in this path through the tree
- | Fail ConflictSet FailReason
+ | -- | We failed to find a solution in this path through the tree
+ Fail
+ ConflictSet
+ -- ^ The conflict set.
+ FailReason
+ -- ^ The reason for failure.
-- | A package option is a package instance with an optional linking annotation
--
@@ -96,7 +141,12 @@ data Tree d c =
-- dependencies must also be the exact same).
--
-- See for details.
-data POption = POption I (Maybe PackagePath)
+data POption
+ = POption
+ I
+ -- ^ The choosen package instance.
+ (Maybe PackagePath)
+ -- ^ The package this choice is linked to (if any).
deriving (Eq, Show)
data FailReason = UnsupportedExtension Extension
@@ -133,7 +183,14 @@ data FailReason = UnsupportedExtension Extension
deriving (Eq, Show)
-- | Information about a dependency involved in a conflict, for error messages.
-data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI
+data ConflictingDep
+ = ConflictingDep
+ (DependencyReason QPN)
+ -- ^ The reason for the dependency.
+ (PkgComponent QPN)
+ -- ^ The component of the package that caused the conflict.
+ CI
+ -- ^ The constrained instance.
deriving (Eq, Show)
-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'
@@ -164,10 +221,10 @@ inn (DoneF x s ) = Done x s
inn (FailF c x ) = Fail c x
innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)
-innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts)
-innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts)
-innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts)
-innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts)
+innM (PChoiceF p s i ts) = PChoice p s i <$> sequence ts
+innM (FChoiceF p s i b m d ts) = FChoice p s i b m d <$> sequence ts
+innM (SChoiceF p s i b ts) = SChoice p s i b <$> sequence ts
+innM (GoalChoiceF s ts) = GoalChoice s <$> sequence ts
innM (DoneF x s ) = return $ Done x s
innM (FailF c x ) = return $ Fail c x
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
index 4af149b31cf..3623a11d5df 100644
--- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
@@ -35,6 +35,7 @@ import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
import Distribution.Types.LibraryName
import Distribution.Types.PkgconfigVersionRange
+import Distribution.Solver.Types.Stage (Staged (..), Stage (..))
-- In practice, most constraints are implication constraints (IF we have made
-- a number of choices, THEN we also have to ensure that). We call constraints
@@ -88,9 +89,9 @@ import Distribution.Types.PkgconfigVersionRange
-- | The state needed during validation.
data ValidateState = VS {
- supportedExt :: Extension -> Bool,
- supportedLang :: Language -> Bool,
- presentPkgs :: Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool),
+ supportedExt :: Stage -> Extension -> Bool,
+ supportedLang :: Stage -> Language -> Bool,
+ presentPkgs :: Stage -> Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool),
index :: Index,
-- Saved, scoped, dependencies. Every time 'validate' makes a package choice,
@@ -191,7 +192,7 @@ validate = go
-- What to do for package nodes ...
goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
- goP qpn@(Q _pp pn) (POption i _) r = do
+ goP qpn@(Q (PackagePath _stage _) pn) (POption i _mpp) r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
@@ -202,15 +203,16 @@ validate = go
rComps <- asks requiredComponents
qo <- asks qualifyOptions
-- obtain dependencies and index-dictated exclusions introduced by the choice
+ let I stage _vr _loc = i
let (PInfo deps comps _ mfr) = idx ! pn ! i
-- qualify the deps in the current scope
- let qdeps = qualifyDeps qo qpn deps
+ let qdeps = qualifyDeps qpn deps
-- the new active constraints are given by the instance we have chosen,
-- plus the dependency information we have for that instance
let newactives = extractAllDeps pfa psa qdeps
-- We now try to extend the partial assignment with the new active constraints.
- let mnppa = extend extSupported langSupported pkgPresent newactives
- =<< extendWithPackageChoice (PI qpn i) ppa
+ let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives
+ =<< extendWithPackageChoice (PI qpn i) ppa
-- In case we continue, we save the scoped dependencies
let nsvd = M.insert qpn qdeps svd
case mfr of
@@ -235,7 +237,7 @@ validate = go
-- What to do for flag nodes ...
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
- goF qfn@(FN qpn _f) b r = do
+ goF qfn@(FN qpn@(Q (PackagePath stage _) _) _f) b r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
@@ -257,7 +259,7 @@ validate = go
let newactives = extractNewDeps (F qfn) b npfa psa qdeps
mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives
-- As in the package case, we try to extend the partial assignment.
- let mnppa = extend extSupported langSupported pkgPresent newactives ppa
+ let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa
case liftM2 (,) mnppa mNewRequiredComps of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right (nppa, rComps') ->
@@ -265,7 +267,7 @@ validate = go
-- What to do for stanza nodes (similar to flag nodes) ...
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
- goS qsn@(SN qpn _f) b r = do
+ goS qsn@(SN qpn@(Q (PackagePath stage _) _) _f) b r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
@@ -287,7 +289,7 @@ validate = go
let newactives = extractNewDeps (S qsn) b pfa npsa qdeps
mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives
-- As in the package case, we try to extend the partial assignment.
- let mnppa = extend extSupported langSupported pkgPresent newactives ppa
+ let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa
case liftM2 (,) mnppa mNewRequiredComps of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right (nppa, rComps') ->
@@ -331,7 +333,14 @@ checkComponentsInNewPackage required qpn providedComps =
-- | We try to extract as many concrete dependencies from the given flagged
-- dependencies as possible. We make use of all the flag knowledge we have
-- already acquired.
-extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
+extractAllDeps
+ :: FAssignment
+ -- ^ current flag assignments
+ -> SAssignment
+ -- ^ current stanza assignments
+ -> FlaggedDeps QPN
+ -- ^ conditional dependencies
+ -> [LDep QPN]
extractAllDeps fa sa deps = do
d <- deps
case d of
@@ -348,7 +357,19 @@ extractAllDeps fa sa deps = do
-- | We try to find new dependencies that become available due to the given
-- flag or stanza choice. We therefore look for the choice in question, and then call
-- 'extractAllDeps' for everything underneath.
-extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]
+extractNewDeps
+ :: Var QPN
+ -- ^ the variable (package, flag or stanza)
+ -> Bool
+ -- ^ the variable value
+ -> FAssignment
+ -- ^ current flag assignments
+ -> SAssignment
+ -- ^ current stanza assignments
+ -> FlaggedDeps QPN
+ -- ^ conditional dependencies
+ -> [LDep QPN]
+ -- ^ dependencies with a reason
extractNewDeps v b fa sa = go
where
go :: FlaggedDeps QPN -> [LDep QPN]
@@ -452,14 +473,14 @@ merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed
, ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
-merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))
+merge (MergedDepFixed comp1 vs1 i@(I _ v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))
| checkVR vr v = Right $ MergedDepFixed comp1 vs1 i
| otherwise =
Left ( createConflictSetForVersionConflict p v vs1 vr vs2
, ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i)
, ConflictingDep vs2 (PkgComponent p comp2) ci ) )
-merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) =
+merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I _ v _))) =
go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...
where
go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
@@ -563,15 +584,13 @@ extendRequiredComponents eqpn available = foldM extendSingle
-- | Interface.
-validateTree :: CompilerInfo -> Index -> Maybe PkgConfigDb -> Tree d c -> Tree d c
-validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {
- supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported
- (\ es -> let s = S.fromList es in \ x -> S.member x s)
- (compilerInfoExtensions cinfo)
- , supportedLang = maybe (const True)
- (flip L.elem) -- use list lookup because language list is small and no Ord instance
- (compilerInfoLanguages cinfo)
- , presentPkgs = pkgConfigPkgIsPresent <$> pkgConfigDb
+validateTree :: Staged CompilerInfo -> Staged (Maybe PkgConfigDb) -> Index -> Tree d c -> Tree d c
+validateTree cinfo pkgConfigDb idx t = runValidate (validate t) VS
+ { -- if compiler has no list of extensions, we assume everything is supported
+ supportedExt = maybe (const True) (flip S.member) . getStage extSet
+ , -- if compiler has no list of extensions, we assume everything is supported
+ supportedLang = maybe (const True) (flip S.member) . getStage langSet
+ , presentPkgs = fmap pkgConfigPkgIsPresent . getStage pkgConfigDb
, index = idx
, saved = M.empty
, pa = PA M.empty M.empty M.empty
@@ -579,3 +598,9 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {
, requiredComponents = M.empty
, qualifyOptions = defaultQualifyOptions idx
}
+ where
+ extSet :: Staged (Maybe (S.Set Extension))
+ extSet = fmap (fmap S.fromList . compilerInfoExtensions) cinfo
+
+ langSet :: Staged (Maybe (S.Set Language))
+ langSet = fmap (fmap S.fromList . compilerInfoLanguages) cinfo
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs
index 2390eefc82a..4355a797cd6 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs
@@ -31,20 +31,19 @@ module Distribution.Solver.Types.ComponentDeps (
, fromInstalled
-- ** Deconstructing ComponentDeps
, toList
- , flatDeps
, nonSetupDeps
, libraryDeps
, setupDeps
, select
, components
+ , null
) where
import Prelude ()
import Distribution.Types.UnqualComponentName
-import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip)
+import Distribution.Solver.Compat.Prelude hiding (null, empty, toList, zip)
import qualified Data.Map as Map
-import Data.Foldable (fold)
import Distribution.Pretty (Pretty (..))
import qualified Distribution.Types.ComponentName as CN
@@ -134,6 +133,9 @@ insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps
aux Nothing = Just a
aux (Just a') = Just $ a `mappend` a'
+null :: ComponentDeps a -> Bool
+null = Map.null . unComponentDeps
+
-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty'
-- as the neutral element when a 'Component' is present only in one.
zip
@@ -176,14 +178,6 @@ fromInstalled = fromLibraryDeps
toList :: ComponentDeps a -> [ComponentDep a]
toList = Map.toList . unComponentDeps
--- | All dependencies of a package.
---
--- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more
--- obvious than a use of 'fold', and moreover this avoids introducing lots of
--- @#ifdef@s for 7.10 just for the use of 'fold'.
-flatDeps :: Monoid a => ComponentDeps a -> a
-flatDeps = fold
-
-- | All dependencies except the setup dependencies.
--
-- Prior to the introduction of setup dependencies in version 1.24 this
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs
index 4244a080064..25cc04c393b 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs
@@ -60,6 +60,9 @@ data ConstraintSource =
-- | An internal constraint due to compatibility issues with the Setup.hs
-- command line interface requires a maximum upper bound on Cabal
| ConstraintSetupCabalMaxVersion
+
+ -- | TODO
+ | ConstraintHideInstalledPackagesSpecificBySourcePackageId
deriving (Show, Eq, Generic)
instance Binary ConstraintSource
@@ -95,3 +98,5 @@ instance Pretty ConstraintSource where
text "minimum version of Cabal used by Setup.hs"
ConstraintSetupCabalMaxVersion ->
text "maximum version of Cabal used by Setup.hs"
+ ConstraintHideInstalledPackagesSpecificBySourcePackageId ->
+ text "HideInstalledPackagesSpecificBySourcePackageId"
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
index 956a4e14849..d58dfe49af3 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
@@ -15,7 +15,10 @@ import Distribution.Solver.Types.Progress
( Progress )
import Distribution.Solver.Types.ResolverPackage
( ResolverPackage )
-import Distribution.Solver.Types.SourcePackage ( SourcePackage )
+import Distribution.Solver.Types.SourcePackage
+ ( SourcePackage )
+import Distribution.Solver.Types.Stage
+ ( Staged )
import Distribution.Solver.Types.SummarizedMessage
( SummarizedMessage(..) )
import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
@@ -31,11 +34,10 @@ import Distribution.System ( Platform )
-- solving the package dependency problem and we want to make it easy to swap
-- in alternatives.
--
-type DependencyResolver loc = Platform
- -> CompilerInfo
- -> InstalledPackageIndex
+type DependencyResolver loc = Staged (CompilerInfo, Platform)
+ -> Staged (Maybe PkgConfigDb)
+ -> Staged InstalledPackageIndex
-> PackageIndex (SourcePackage loc)
- -> Maybe PkgConfigDb
-> (PackageName -> PackagePreferences)
-> [LabeledPackageConstraint]
-> Set PackageName
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs
index 871a0dd15a9..b2358bca348 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs
@@ -8,7 +8,9 @@ import Prelude ()
import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) )
import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )
+import Distribution.Solver.Types.PackagePath (QPN)
import Distribution.Solver.Types.SolverId
+import Distribution.Solver.Types.Stage (Stage)
import Distribution.Types.MungedPackageId
import Distribution.Types.PackageId
import Distribution.Types.MungedPackageName
@@ -17,6 +19,8 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-- | An 'InstSolverPackage' is a pre-existing installed package
-- specified by the dependency solver.
data InstSolverPackage = InstSolverPackage {
+ instSolverStage :: Stage,
+ instSolverQPN :: QPN,
instSolverPkgIPI :: InstalledPackageInfo,
instSolverPkgLibDeps :: ComponentDeps [SolverId],
instSolverPkgExeDeps :: ComponentDeps [SolverId]
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs
index 9b5db378b6a..e7525d24f29 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs
@@ -7,6 +7,7 @@
--
module Distribution.Solver.Types.PackageConstraint (
ConstraintScope(..),
+ ConstraintQualifier(..),
scopeToplevel,
scopeToPackageName,
constraintScopeMatches,
@@ -29,11 +30,21 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import qualified Text.PrettyPrint as Disp
+import Distribution.Solver.Types.Toolchain (Stage (..))
-- | Determines to what packages and in what contexts a
-- constraint applies.
-data ConstraintScope
+data ConstraintScope =
+ ConstraintScope
+ -- | The stage at which the constraint applies, if any.
+ -- If Nothing, the constraint applies to all stages.
+ (Maybe Stage)
+ -- | The qualifier that determines the scope of the constraint.
+ ConstraintQualifier
+ deriving (Eq, Show)
+
+data ConstraintQualifier
-- | A scope that applies when the given package is used as a build target.
-- In other words, the scope applies iff a goal has a top-level qualifier
-- and its namespace matches the given package name. A namespace is
@@ -46,44 +57,54 @@ data ConstraintScope
= ScopeTarget PackageName
-- | The package with the specified name and qualifier.
| ScopeQualified Qualifier PackageName
- -- | The package with the specified name when it has a
- -- setup qualifier.
+ -- | The package with the specified name when it has a setup qualifier.
| ScopeAnySetupQualifier PackageName
- -- | The package with the specified name regardless of
- -- qualifier.
+ -- | The package with the specified name when it has an exe qualifier.
+ | ScopeAnyExeQualifier PackageName
+ -- | The package with the specified name regardless of qualifier.
| ScopeAnyQualifier PackageName
deriving (Eq, Show)
-- | Constructor for a common use case: the constraint applies to
-- the package with the specified name when that package is a
--- top-level dependency in the default namespace.
+-- top-level dependency in the host stage.
scopeToplevel :: PackageName -> ConstraintScope
-scopeToplevel = ScopeQualified QualToplevel
+scopeToplevel = ConstraintScope (Just Host) . ScopeQualified QualToplevel
-- | Returns the package name associated with a constraint scope.
scopeToPackageName :: ConstraintScope -> PackageName
-scopeToPackageName (ScopeTarget pn) = pn
-scopeToPackageName (ScopeQualified _ pn) = pn
-scopeToPackageName (ScopeAnySetupQualifier pn) = pn
-scopeToPackageName (ScopeAnyQualifier pn) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeAnyExeQualifier pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn
constraintScopeMatches :: ConstraintScope -> QPN -> Bool
-constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') =
- let namespaceMatches DefaultNamespace = True
- namespaceMatches (Independent namespacePn) = pn == namespacePn
- in namespaceMatches ns && q == QualToplevel && pn == pn'
-constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =
- q == q' && pn == pn'
-constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =
- let setup (PackagePath _ (QualSetup _)) = True
- setup _ = False
- in setup pp && pn == pn'
-constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'
+constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') =
+ maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn'
+
+constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool
+constraintQualifierMatches (ScopeTarget pn) QualToplevel pn' = pn == pn'
+constraintQualifierMatches (ScopeTarget _) (QualSetup _) _ = False
+constraintQualifierMatches (ScopeTarget _) (QualExe _ _) _ = False
+constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn'
+constraintQualifierMatches (ScopeAnySetupQualifier _) QualToplevel _ = False
+constraintQualifierMatches (ScopeAnySetupQualifier _) (QualExe _ _) _ = False
+constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn == pn'
+constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn'
+constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False
+constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False
+constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn'
instance Pretty ConstraintScope where
+ pretty (ConstraintScope mstage qualifier) =
+ maybe mempty pretty mstage <+> pretty qualifier
+
+instance Pretty ConstraintQualifier where
pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn
+ pretty (ScopeAnyExeQualifier pn) = Disp.text "exe." <<>> pretty pn
pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn
-- | A package property is a logical predicate on packages.
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs
index 4fc4df25f97..069e45181e0 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs
@@ -1,6 +1,7 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
module Distribution.Solver.Types.PackagePath
( PackagePath(..)
- , Namespace(..)
, Qualifier(..)
, dispQualifier
, Qualified(..)
@@ -12,31 +13,19 @@ module Distribution.Solver.Types.PackagePath
import Distribution.Solver.Compat.Prelude
import Prelude ()
import Distribution.Package (PackageName)
-import Distribution.Pretty (pretty, flatStyle)
+import Distribution.Pretty (pretty, flatStyle, Pretty)
import qualified Text.PrettyPrint as Disp
+import Distribution.Solver.Types.Stage (Stage)
--- | A package path consists of a namespace and a package path inside that
--- namespace.
-data PackagePath = PackagePath Namespace Qualifier
- deriving (Eq, Ord, Show)
+data PackagePath = PackagePath Stage Qualifier
+ deriving (Eq, Ord, Show, Generic)
--- | Top-level namespace
---
--- Package choices in different namespaces are considered completely independent
--- by the solver.
-data Namespace =
- -- | The default namespace
- DefaultNamespace
-
- -- | A namespace for a specific build target
- | Independent PackageName
- deriving (Eq, Ord, Show)
-
--- | Pretty-prints a namespace. The result is either empty or
--- ends in a period, so it can be prepended onto a qualifier.
-dispNamespace :: Namespace -> Disp.Doc
-dispNamespace DefaultNamespace = Disp.empty
-dispNamespace (Independent i) = pretty i <<>> Disp.text "."
+instance Binary PackagePath
+instance Structured PackagePath
+
+instance Pretty PackagePath where
+ pretty (PackagePath stage qualifier) =
+ pretty stage <<>> Disp.text ":" <<>> pretty qualifier
-- | Qualifier of a package within a namespace (see 'PackagePath')
data Qualifier =
@@ -68,7 +57,16 @@ data Qualifier =
-- tracked only @pn2@, that would require us to pick only one
-- version of an executable over the entire install plan.)
| QualExe PackageName PackageName
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
+
+instance Binary Qualifier
+instance Structured Qualifier
+
+instance Pretty Qualifier where
+ pretty QualToplevel = Disp.text "toplevel"
+ pretty (QualSetup pn) = pretty pn <<>> Disp.text ":setup"
+ pretty (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>
+ pretty pn2 <<>> Disp.text ":exe"
-- | Pretty-prints a qualifier. The result is either empty or
-- ends in a period, so it can be prepended onto a package name.
@@ -79,23 +77,31 @@ data Qualifier =
-- is the qualifier and @"base"@ is the actual dependency (which, for the
-- 'Base' qualifier, will always be @base@).
dispQualifier :: Qualifier -> Disp.Doc
-dispQualifier QualToplevel = Disp.empty
-dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup."
-dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>
- pretty pn2 <<>> Disp.text ":exe."
-dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "."
+dispQualifier QualToplevel = mempty
+dispQualifier (QualSetup pn) = pretty pn <> Disp.text ":setup."
+dispQualifier (QualExe pn pn2) =
+ pretty pn
+ <> Disp.text ":"
+ <> pretty pn2
+ <> Disp.text ":exe."
-- | A qualified entity. Pairs a package path with the entity.
data Qualified a = Q PackagePath a
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
+
+instance (Binary a) => Binary (Qualified a)
+instance (Structured a) => Structured (Qualified a)
-- | Qualified package name.
type QPN = Qualified PackageName
+instance Pretty (Qualified PackageName) where
+ pretty (Q (PackagePath stage qual) pn) =
+ pretty stage <<>> Disp.colon <<>> dispQualifier qual <<>> pretty pn
+
-- | Pretty-prints a qualified package name.
dispQPN :: QPN -> Disp.Doc
-dispQPN (Q (PackagePath ns qual) pn) =
- dispNamespace ns <<>> dispQualifier qual <<>> pretty pn
+dispQPN = pretty
-- | String representation of a qualified package name.
showQPN :: QPN -> String
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs
index 6053fbf4f56..e5d12bf86a0 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs
@@ -82,19 +82,18 @@ readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do
. filter (either (const True) (not . null))
-- Try decoding strictly; if it fails, put the lenient
-- decoding in a Left for later reporting.
- . map (\bsname ->
- let sbsname = LBS.toStrict bsname
- in case T.decodeUtf8' sbsname of
- Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname))
- Right name -> Right (T.unpack name))
-- The output of @pkg-config --list-all@ also includes a
-- description for each package, which we do not need.
-- We don't use Data.Char.isSpace because that would also
-- include 0xA0, the non-breaking space, which can occur
-- in multi-byte UTF-8 sequences.
- . map (LBS.takeWhile (not . isAsciiSpace))
+ . map ((\bsname ->
+ let sbsname = LBS.toStrict bsname
+ in case T.decodeUtf8' sbsname of
+ Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname))
+ Right name -> Right (T.unpack name)) . LBS.takeWhile (not . isAsciiSpace))
$ pkgList
- when (not (null failedPkgNames)) $
+ unless (null failedPkgNames) $
info verbosity ("Some pkg-config packages have names containing invalid unicode: " ++ intercalate ", " failedPkgNames)
(outs, _errs, exitCode) <-
getProgramInvocationOutputAndErrors verbosity
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
index 107c8e58350..b70e12a26e3 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
@@ -1,10 +1,13 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
module Distribution.Solver.Types.Progress
( Progress(..)
, foldProgress
+ , step
) where
import Prelude ()
-import Distribution.Solver.Compat.Prelude hiding (fail)
+import Distribution.Solver.Compat.Prelude
-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
@@ -13,14 +16,10 @@ import Distribution.Solver.Compat.Prelude hiding (fail)
data Progress step fail done = Step step (Progress step fail done)
| Fail fail
| Done done
+ deriving (Functor)
--- This Functor instance works around a bug in GHC 7.6.3.
--- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637.
--- The derived functor instance caused a space leak in the solver.
-instance Functor (Progress step fail) where
- fmap f (Step s p) = Step s (fmap f p)
- fmap _ (Fail x) = Fail x
- fmap f (Done r) = Done (f r)
+step :: step -> Progress step fail ()
+step s = Step s (Done ())
-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two
-- base cases, one for a final result and one for failure.
@@ -31,15 +30,18 @@ instance Functor (Progress step fail) where
--
foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)
-> Progress step fail done -> a
-foldProgress step fail done = fold
- where fold (Step s p) = step s (fold p)
- fold (Fail f) = fail f
- fold (Done r) = done r
+foldProgress step' fail' done' = fold
+ where fold (Step s p) = step' s (fold p)
+ fold (Fail f) = fail' f
+ fold (Done r) = done' r
instance Monad (Progress step fail) where
return = pure
p >>= f = foldProgress Step Fail f p
+instance MonadFail (Progress step String) where
+ fail = Fail
+
instance Applicative (Progress step fail) where
pure a = Done a
p <*> x = foldProgress Step Fail (`fmap` x) p
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs
index 840e58aff94..9458e7ee0b1 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs
@@ -2,6 +2,8 @@
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Solver.Types.ResolverPackage
( ResolverPackage(..)
+ , solverId
+ , solverQPN
, resolverPackageLibDeps
, resolverPackageExeDeps
) where
@@ -12,11 +14,13 @@ import Prelude ()
import Distribution.Solver.Types.InstSolverPackage
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
+import Distribution.Solver.Types.PackagePath (QPN)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Compat.Graph (IsNode(..))
import Distribution.Package (Package(..), HasUnitId(..))
import Distribution.Simple.Utils (ordNub)
+import Data.Foldable (fold)
-- | The dependency resolver picks either pre-existing installed packages
-- or it picks source packages along with package configuration.
@@ -34,6 +38,14 @@ instance Package (ResolverPackage loc) where
packageId (PreExisting ipkg) = packageId ipkg
packageId (Configured spkg) = packageId spkg
+solverId :: ResolverPackage loc -> SolverId
+solverId (PreExisting ipkg) = PreExistingId (instSolverStage ipkg) (packageId ipkg) (installedUnitId ipkg)
+solverId (Configured spkg) = PlannedId (solverPkgStage spkg) (packageId spkg)
+
+solverQPN :: ResolverPackage loc -> QPN
+solverQPN (PreExisting ipkg) = instSolverQPN ipkg
+solverQPN (Configured spkg) = solverPkgQPN spkg
+
resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]
resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg
resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg
@@ -44,9 +56,9 @@ resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg
instance IsNode (ResolverPackage loc) where
type Key (ResolverPackage loc) = SolverId
- nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg)
- nodeKey (Configured spkg) = PlannedId (packageId spkg)
+ nodeKey = solverId
+
-- Use dependencies for ALL components
nodeNeighbors pkg =
- ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++
- CD.flatDeps (resolverPackageExeDeps pkg)
+ ordNub $ fold (resolverPackageLibDeps pkg) ++
+ fold (resolverPackageExeDeps pkg)
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs
index d32ccc17e74..9afb8bf1338 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs
@@ -9,14 +9,19 @@ import Distribution.Solver.Compat.Prelude
import Prelude ()
import Distribution.Package (PackageId, Package(..), UnitId)
+import Distribution.Pretty (Pretty (..))
+import Distribution.Solver.Types.Stage (Stage)
+
+import Text.PrettyPrint (colon, punctuate, text)
+
-- | The solver can produce references to existing packages or
-- packages we plan to install. Unlike 'ConfiguredId' we don't
-- yet know the 'UnitId' for planned packages, because it's
-- not the solver's job to compute them.
--
-data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId }
- | PlannedId { solverSrcId :: PackageId }
+data SolverId = PreExistingId { solverStage :: Stage, solverSrcId :: PackageId, solverInstId :: UnitId }
+ | PlannedId { solverStage :: Stage, solverSrcId :: PackageId }
deriving (Eq, Ord, Generic)
instance Binary SolverId
@@ -27,3 +32,7 @@ instance Show SolverId where
instance Package SolverId where
packageId = solverSrcId
+
+instance Pretty SolverId where
+ pretty (PreExistingId stage pkg unitId) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "installed", pretty unitId]
+ pretty (PlannedId stage pkg) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "planned"]
\ No newline at end of file
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs
index 186f140aefe..f170542ac19 100644
--- a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs
+++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs
@@ -12,6 +12,8 @@ import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Stage ( Stage )
+import Distribution.Solver.Types.PackagePath ( QPN )
-- | A 'SolverPackage' is a package specified by the dependency solver.
-- It will get elaborated into a 'ConfiguredPackage' or even an
@@ -21,6 +23,8 @@ import Distribution.Solver.Types.SourcePackage
-- but for symmetry we have the parameter. (Maybe it can be removed.)
--
data SolverPackage loc = SolverPackage {
+ solverPkgStage :: Stage,
+ solverPkgQPN :: QPN,
solverPkgSource :: SourcePackage loc,
solverPkgFlags :: FlagAssignment,
solverPkgStanzas :: OptionalStanzaSet,
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs
new file mode 100644
index 00000000000..54880a0491b
--- /dev/null
+++ b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveTraversable #-}
+
+module Distribution.Solver.Types.Stage
+ ( Stage (..)
+ , showStage
+ , stages
+ , prevStage
+ , nextStage
+ , Staged (..)
+ , tabulate
+ , foldMapWithKey
+ , always
+ ) where
+
+import Prelude (Enum (..))
+import Distribution.Compat.Prelude
+import qualified Distribution.Compat.CharParsing as P
+
+import Data.Maybe (fromJust)
+import GHC.Stack
+
+import Distribution.Parsec (Parsec (..))
+import Distribution.Pretty (Pretty (..))
+import Distribution.Utils.Structured (Structured (..))
+import qualified Text.PrettyPrint as Disp
+
+
+data Stage
+ = -- | -- The system where the build is running
+ Build
+ | -- | -- The system where the built artifacts will run
+ Host
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+
+instance Binary Stage
+instance Structured Stage
+instance NFData Stage
+
+instance Pretty Stage where
+ pretty = Disp.text . showStage
+
+showStage :: Stage -> String
+showStage Build = "build"
+showStage Host = "host"
+
+instance Parsec Stage where
+ parsec = P.choice [
+ Build <$ P.string "build",
+ Host <$ P.string "host"
+ ]
+
+stages :: [Stage]
+stages = [minBound .. maxBound]
+
+prevStage :: Stage -> Stage
+prevStage s | s == minBound = s
+ | otherwise = Prelude.pred s
+nextStage :: Stage -> Stage
+nextStage s | s == maxBound = s
+ | otherwise = Prelude.succ s
+
+-- TOOD: I think there is similar code for stanzas, compare.
+
+newtype Staged a = Staged
+ { getStage :: Stage -> a
+ }
+ deriving (Functor, Generic)
+ deriving Applicative via ((->) Stage)
+
+instance Eq a => Eq (Staged a) where
+ lhs == rhs =
+ all
+ (\stage -> getStage lhs stage == getStage rhs stage)
+ [minBound .. maxBound]
+
+instance Show a => Show (Staged a) where
+ showsPrec _ staged =
+ showList
+ [ (stage, getStage staged stage)
+ | stage <- [minBound .. maxBound]
+ ]
+
+instance Foldable Staged where
+ foldMap f (Staged gs) = foldMap (f . gs) [minBound..maxBound]
+
+instance Traversable Staged where
+ traverse f = fmap index . traverse (traverse f) . tabulate
+
+instance Binary a => Binary (Staged a) where
+ put staged = put (tabulate staged)
+ -- TODO this could be done better I think
+ get = index <$> get
+
+-- TODO: I have no idea if this is right
+instance (Typeable a, Structured a) => Structured (Staged a) where
+ structure _ = structure (Proxy :: Proxy [(Stage, a)])
+
+tabulate :: Staged a -> [(Stage, a)]
+tabulate staged =
+ [ (stage, getStage staged stage)
+ | stage <- [minBound .. maxBound]
+ ]
+
+index :: HasCallStack => [(Stage, a)] -> Staged a
+index t = Staged (\s -> fromJust (lookup s t))
+
+foldMapWithKey :: Monoid m => (Stage -> a -> m) -> Staged a -> m
+foldMapWithKey f = foldMap (uncurry f) . tabulate
+
+always :: a -> Staged a
+always = Staged . const
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs
new file mode 100644
index 00000000000..6ee663795f4
--- /dev/null
+++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Solver.Types.Toolchain
+ ( Toolchain (..)
+ , Toolchains
+ , Stage (..)
+ , Staged (..)
+ ) where
+
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Distribution.Simple.Compiler
+import Distribution.Simple.Program.Db
+import Distribution.Solver.Types.Stage (getStage, Stage (..), Staged (..))
+import Distribution.System
+
+---------------------------
+-- Toolchain
+--
+
+data Toolchain = Toolchain
+ { toolchainPlatform :: Platform
+ , toolchainCompiler :: Compiler
+ , toolchainProgramDb :: ProgramDb
+ -- NOTE: actually the solver does not care about package dbs, perhaps it's better
+ -- to have a separate Toolchain type for project planning.
+ , toolchainPackageDBs :: PackageDBStackCWD
+ }
+ deriving (Show, Generic)
+
+-- TODO: review this
+instance Eq Toolchain where
+ lhs == rhs =
+ (((==) `on` toolchainPlatform) lhs rhs)
+ && (((==) `on` toolchainCompiler) lhs rhs)
+ && ((((==)) `on` (configuredPrograms . toolchainProgramDb)) lhs rhs)
+
+instance Binary Toolchain
+instance Structured Toolchain
+
+type Toolchains = Staged Toolchain
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 933e361be30..afc02f636ad 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -167,6 +167,7 @@ library
Distribution.Client.Init.Simple
Distribution.Client.Init.Types
Distribution.Client.Init.Utils
+ Distribution.Client.InLibrary
Distribution.Client.Install
Distribution.Client.InstallPlan
Distribution.Client.InstallSymlink
@@ -193,6 +194,7 @@ library
Distribution.Client.ProjectPlanOutput
Distribution.Client.ProjectPlanning
Distribution.Client.ProjectPlanning.SetupPolicy
+ Distribution.Client.ProjectPlanning.Stage
Distribution.Client.ProjectPlanning.Types
Distribution.Client.RebuildMonad
Distribution.Client.Reconfigure
@@ -215,12 +217,14 @@ library
Distribution.Client.TargetProblem
Distribution.Client.TargetSelector
Distribution.Client.Targets
+ Distribution.Client.Toolchain
Distribution.Client.Types
Distribution.Client.Types.AllowNewer
Distribution.Client.Types.BuildResults
Distribution.Client.Types.ConfiguredId
Distribution.Client.Types.ConfiguredPackage
Distribution.Client.Types.Credentials
+ Distribution.Client.Types.GenericReadyPackage
Distribution.Client.Types.InstallMethod
Distribution.Client.Types.OverwritePolicy
Distribution.Client.Types.PackageLocation
@@ -253,6 +257,7 @@ library
, edit-distance >= 0.2.2 && < 0.3
, exceptions >= 0.10.4 && < 0.11
, filepath >= 1.4.0.0 && < 1.6
+ , hooks-exe ^>= 0.1
, HTTP >= 4000.1.5 && < 4000.6
, mtl >= 2.0 && < 2.4
, network-uri >= 2.6.2.0 && < 2.7
@@ -261,7 +266,7 @@ library
, random >= 1.2 && < 1.4
, stm >= 2.0 && < 2.6
, tar >= 0.5.0.3 && < 0.8
- , time >= 1.5.0.1 && < 1.16
+ , time >= 1.5.0.1 && < 1.17
, zlib >= 0.6 && < 0.8
, hackage-security >= 0.6.2.0 && < 0.7
, text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2
@@ -341,6 +346,7 @@ test-suite unit-tests
UnitTests.Distribution.Client.Glob
UnitTests.Distribution.Client.GZipUtils
UnitTests.Distribution.Client.IndexUtils
+ UnitTests.Distribution.Client.IndexUtils.ActiveRepos
UnitTests.Distribution.Client.IndexUtils.Timestamp
UnitTests.Distribution.Client.Init
UnitTests.Distribution.Client.Init.Golden
@@ -454,7 +460,7 @@ test-suite integration-tests2
, directory
, filepath
, process
- , tasty >= 1.5 && <1.6
+ , tasty >= 1.5.4 && <1.6
, tasty-hunit >= 0.10
, tasty-expected-failure
, silently
diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs
index 66898b328ed..7079f2119b9 100644
--- a/cabal-install/parser-tests/Tests/ParserTests.hs
+++ b/cabal-install/parser-tests/Tests/ParserTests.hs
@@ -99,18 +99,18 @@ testPackages :: Assertion
testPackages = do
let expected = [".", "packages/packages.cabal"]
(config, legacy) <- readConfigDefault "packages"
- assertConfigEquals expected config legacy (projectPackages . condTreeData)
+ assertConfigEquals expected config legacy (projectPackages . snd . condTreeData)
testOptionalPackages :: Assertion
testOptionalPackages = do
let expected = [".", "packages/packages.cabal"]
(config, legacy) <- readConfigDefault "optional-packages"
- assertConfigEquals expected config legacy (projectPackagesOptional . condTreeData)
+ assertConfigEquals expected config legacy (projectPackagesOptional . snd . condTreeData)
testSourceRepoList :: Assertion
testSourceRepoList = do
(config, legacy) <- readConfigDefault "source-repository-packages"
- assertConfigEquals expected config legacy (projectPackagesRepo . condTreeData)
+ assertConfigEquals expected config legacy (projectPackagesRepo . snd . condTreeData)
where
expected =
[ SourceRepositoryPackage
@@ -134,7 +134,7 @@ testSourceRepoList = do
testExtraPackages :: Assertion
testExtraPackages = do
(config, legacy) <- readConfigDefault "extra-packages"
- assertConfigEquals expected config legacy (projectPackagesNamed . condTreeData)
+ assertConfigEquals expected config legacy (projectPackagesNamed . snd . condTreeData)
where
expected =
[ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0]))
@@ -144,7 +144,7 @@ testExtraPackages = do
testProjectConfigBuildOnly :: Assertion
testProjectConfigBuildOnly = do
(config, legacy) <- readConfigDefault "project-config-build-only"
- assertConfigEquals expected config legacy (projectConfigBuildOnly . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigBuildOnly . snd . condTreeData)
where
expected = ProjectConfigBuildOnly{..}
projectConfigVerbosity = toFlag (mkVerbosityFlags Verbose)
@@ -177,9 +177,10 @@ testProjectConfigBuildOnly = do
testProjectConfigShared :: Assertion
testProjectConfigShared = do
(config, legacy) <- readConfigDefault "project-config-shared"
- assertConfigEquals expected config legacy (projectConfigShared . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigShared . snd . condTreeData)
where
expected = ProjectConfigShared{..}
+ projectConfigToolchain = ProjectConfigToolchain{..}
projectConfigDistDir = toFlag "something"
projectConfigConfigFile = mempty -- cli only
projectConfigProjectFileParser = mempty -- cli only
@@ -189,9 +190,13 @@ testProjectConfigShared = do
projectConfigHcFlavor = toFlag GHCJS
projectConfigHcPath = toFlag "/some/path/to/compiler"
projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg"
+ projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")]
+ projectConfigBuildHcFlavor = toFlag GHCJS
+ projectConfigBuildHcPath = toFlag "/some/path/to/compiler"
+ projectConfigBuildHcPkg = toFlag "/some/path/to/ghc-pkg"
+ projectConfigBuildPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")]
projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index"
projectConfigInstallDirs = mempty -- tested below in testInstallDirs
- projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")]
projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos
projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos
projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride])
@@ -234,7 +239,7 @@ testProjectConfigShared = do
testInstallDirs :: Assertion
testInstallDirs = do
(config, legacy) <- readConfigDefault "install-dirs"
- assertConfigEquals expected config legacy (projectConfigInstallDirs . projectConfigShared . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigInstallDirs . projectConfigShared . snd . condTreeData)
where
expected =
InstallDirs
@@ -260,9 +265,9 @@ testInstallDirs = do
testRemoteRepos :: Assertion
testRemoteRepos = do
(config, legacy) <- readConfigDefault "remote-repos"
- let actualRemoteRepos = (fromNubList . projectConfigRemoteRepos . projectConfigShared . condTreeData) config
+ let actualRemoteRepos = (fromNubList . projectConfigRemoteRepos . projectConfigShared . snd . condTreeData) config
assertBool "Expected RemoteRepos do not match parsed values" $ compareLists expected actualRemoteRepos compareRemoteRepos
- assertConfigEquals mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData)
+ assertConfigEquals mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData)
where
expected = [packagesRepository, morePackagesRepository, secureLocalRepository]
packagesRepository =
@@ -296,9 +301,9 @@ testRemoteRepos = do
testLocalNoIndexRepos :: Assertion
testLocalNoIndexRepos = do
(config, legacy) <- readConfigDefault "local-no-index-repos"
- let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . condTreeData) config
+ let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData) config
assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected actualLocalRepos compareLocalRepos
- assertConfigEquals mempty config legacy (projectConfigRemoteRepos . projectConfigShared . condTreeData)
+ assertConfigEquals mempty config legacy (projectConfigRemoteRepos . projectConfigShared . snd . condTreeData)
where
expected = [myRepository, mySecureRepository]
myRepository =
@@ -321,12 +326,12 @@ testProjectConfigProvenance :: Assertion
testProjectConfigProvenance = do
let expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| []))
(config, legacy) <- readConfigDefault "empty"
- assertConfigEquals expected config legacy (projectConfigProvenance . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigProvenance . snd . condTreeData)
testProjectConfigLocalPackages :: Assertion
testProjectConfigLocalPackages = do
(config, legacy) <- readConfigDefault "project-config-local-packages"
- assertConfigEquals expected config legacy (projectConfigLocalPackages . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)
where
expected = PackageConfig{..}
packageConfigProgramPaths = MapLast $ Map.fromList [("ghc", "/tmp/bin/ghc"), ("gcc", "/tmp/bin/gcc")]
@@ -398,7 +403,7 @@ testProjectConfigLocalPackages = do
testProjectConfigAllPackages :: Assertion
testProjectConfigAllPackages = do
(config, legacy) <- readConfigDefault "project-config-all-packages"
- assertConfigEquals expected config legacy (projectConfigAllPackages . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigAllPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
@@ -410,7 +415,7 @@ testProjectConfigAllPackages = do
testProjectConfigSpecificPackages :: Assertion
testProjectConfigSpecificPackages = do
(config, legacy) <- readConfigDefault "project-config-specific-packages"
- assertConfigEquals expected config legacy (projectConfigSpecificPackage . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigSpecificPackage . snd . condTreeData)
where
expected = MapMappend $ Map.fromList [("foo", expectedFoo), ("bar", expectedBar), ("baz", expectedBaz)]
expectedFoo :: PackageConfig
@@ -436,7 +441,7 @@ testProjectConfigSpecificPackages = do
testAllPackagesConcat :: Assertion
testAllPackagesConcat = do
(config, legacy) <- readConfigDefault "all-packages-concat"
- assertConfigEquals expected config legacy (projectConfigAllPackages . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigAllPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
@@ -453,7 +458,7 @@ testAllPackagesConcat = do
testSpecificPackagesConcat :: Assertion
testSpecificPackagesConcat = do
(config, legacy) <- readConfigDefault "specific-packages-concat"
- assertConfigEquals expected config legacy (projectConfigSpecificPackage . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigSpecificPackage . snd . condTreeData)
where
expected = MapMappend $ Map.fromList [("foo", expectedFoo)]
expectedFoo :: PackageConfig
@@ -467,7 +472,7 @@ testSpecificPackagesConcat = do
testProgramLocationsConcat :: Assertion
testProgramLocationsConcat = do
(config, legacy) <- readConfigDefault "program-locations-concat"
- assertConfigEquals expected config legacy (projectConfigLocalPackages . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
@@ -478,7 +483,7 @@ testProgramLocationsConcat = do
testProgramOptionsConcat :: Assertion
testProgramOptionsConcat = do
(config, legacy) <- readConfigDefault "program-options-concat"
- assertConfigEquals expected config legacy (projectConfigLocalPackages . condTreeData)
+ assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
@@ -496,8 +501,8 @@ testProgramOptionsConcat = do
testRelaxDepsConcat :: Assertion
testRelaxDepsConcat = do
(config, legacy) <- readConfigDefault "relax-deps-concat"
- assertConfigEquals expectedAllowNewer config legacy (projectConfigAllowNewer . projectConfigShared . condTreeData)
- assertConfigEquals expectedAllowOlder config legacy (projectConfigAllowOlder . projectConfigShared . condTreeData)
+ assertConfigEquals expectedAllowNewer config legacy (projectConfigAllowNewer . projectConfigShared . snd . condTreeData)
+ assertConfigEquals expectedAllowOlder config legacy (projectConfigAllowOlder . projectConfigShared . snd . condTreeData)
where
expectedAllowNewer :: Maybe AllowNewer
expectedAllowNewer =
@@ -522,32 +527,32 @@ testRelaxDepsConcat = do
testLibraryCoverage :: Assertion
testLibraryCoverage = do
(config, legacy) <- readConfigDefault "library-coverage"
- assertConfigEquals (Flag False) config legacy (packageConfigCoverage . projectConfigLocalPackages . condTreeData)
+ assertConfigEquals (Flag False) config legacy (packageConfigCoverage . projectConfigLocalPackages . snd . condTreeData)
testHaddockAll :: Assertion
testHaddockAll = do
(config, legacy) <- readConfigDefault "haddock-all"
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)
-- | Tests that an explicitly set field can override a value inherited from haddock-all.
testHaddockAllOverwriteTrue :: Assertion
testHaddockAllOverwriteTrue = do
(config, legacy) <- readConfigDefault "haddock-all-overwrite-true"
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)
testHaddockAllOverwriteFalse :: Assertion
testHaddockAllOverwriteFalse = do
(config, legacy) <- readConfigDefault "haddock-all-overwrite-false"
- assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag False) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag False) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . condTreeData)
- assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . condTreeData)
+ assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag False) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag False) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)
+ assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)
-------------------------------------------------------------------------------
-- Test Utilities
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs
index 740a32cd9c3..7bb56affa42 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
@@ -91,13 +89,15 @@ storeAnonymous reports =
separate
:: [(BuildReport, Maybe Repo)]
-> [(Repo, [BuildReport])]
- separate =
- map (\rs@((_, repo, _) : _) -> (repo, [r | (r, _, _) <- rs]))
- . map (concatMap toList)
- . L.groupBy (equating (repoName' . head))
- . sortBy (comparing (repoName' . head))
- . groupBy (equating repoName')
- . onlyRemote
+ separate xs =
+ [ (repo, [r | (r, _, _) <- rs])
+ | rs@((_, repo, _) : _) <-
+ map (concatMap toList)
+ . L.groupBy (equating (repoName' . head))
+ . sortBy (comparing (repoName' . head))
+ . groupBy (equating repoName')
+ $ onlyRemote xs
+ ]
repoName' (_, _, rrepo) = remoteRepoName rrepo
@@ -148,10 +148,10 @@ storeLocal cinfo templates reports platform =
cinfo
platform
- groupByFileName =
- map (\grp@((filename, _) : _) -> (filename, map snd grp))
- . L.groupBy (equating fst)
- . sortBy (comparing fst)
+ groupByFileName xs =
+ [ (filename, map snd grp)
+ | grp@((filename, _) : _) <- L.groupBy (equating fst) $ sortBy (comparing fst) xs
+ ]
-- ------------------------------------------------------------
diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs
index f9adc80432b..177b8263a1a 100644
--- a/cabal-install/src/Distribution/Client/CmdBench.hs
+++ b/cabal-install/src/Distribution/Client/CmdBench.hs
@@ -50,6 +50,9 @@ import Distribution.Simple.Utils
, warn
, wrapText
)
+import Distribution.Utils.LogProgress
+ ( runLogProgress
+ )
import Distribution.Verbosity
( normal
)
@@ -133,11 +136,13 @@ benchAction flags targetStrings globalFlags = do
Nothing
targetSelectors
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionBench
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionBench
+ targets
+ elaboratedPlan
+
return (elaboratedPlan', targets)
printPlan verbosity baseCtx buildCtx
diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs
index 7314187b815..b8ca8a3dfd2 100644
--- a/cabal-install/src/Distribution/Client/CmdBuild.hs
+++ b/cabal-install/src/Distribution/Client/CmdBuild.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
-- | cabal-install CLI command: build
module Distribution.Client.CmdBuild
( -- * The @build@ CLI and action
@@ -26,6 +28,7 @@ import Distribution.Client.TargetProblem
import qualified Data.Map as Map
import Distribution.Client.Errors
+import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..)
, cfgVerbosity
@@ -52,6 +55,7 @@ import Distribution.Simple.Utils
( dieWithException
, wrapText
)
+import Distribution.Utils.LogProgress (runLogProgress)
import Distribution.Verbosity
( normal
)
@@ -161,18 +165,20 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags} targetStrings globalFla
Nothing
targetSelectors
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- targetAction
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ targetAction
+ targets
+ elaboratedPlan
+
elaboratedPlan'' <-
if buildSettingOnlyDeps (buildSettings baseCtx)
- then
- either (reportCannotPruneDependencies verbosity) return $
- pruneInstallPlanToDependencies
- (Map.keysSet targets)
- elaboratedPlan'
+ then case pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' of
+ Left err ->
+ reportCannotPruneDependencies verbosity err
+ Right elaboratedPlan'' ->
+ runLogProgress verbosity $ InstallPlan.new' elaboratedPlan''
else return elaboratedPlan'
return (elaboratedPlan'', targets)
diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs
index d3908318d61..21d4b2c9480 100644
--- a/cabal-install/src/Distribution/Client/CmdClean.hs
+++ b/cabal-install/src/Distribution/Client/CmdClean.hs
@@ -51,6 +51,7 @@ import Distribution.Simple.Setup
import Distribution.Simple.Utils
( dieWithException
, info
+ , removeFileForcibly
, wrapText
)
import Distribution.System
@@ -85,7 +86,6 @@ import System.Directory
, doesDirectoryExist
, doesFileExist
, listDirectory
- , removeFile
, removePathForcibly
)
import System.FilePath
@@ -216,5 +216,5 @@ cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do
removeEnvFiles :: FilePath -> IO ()
removeEnvFiles dir =
- (traverse_ (removeFile . (dir )) . filter ((".ghc.environment" ==) . take 16))
+ (traverse_ (removeFileForcibly . (dir )) . filter ((".ghc.environment" ==) . take 16))
=<< listDirectory dir
diff --git a/cabal-install/src/Distribution/Client/CmdConfigure.hs b/cabal-install/src/Distribution/Client/CmdConfigure.hs
index dbaec030520..0de7acaa3eb 100644
--- a/cabal-install/src/Distribution/Client/CmdConfigure.hs
+++ b/cabal-install/src/Distribution/Client/CmdConfigure.hs
@@ -157,14 +157,14 @@ configureAction' flags@NixStyleFlags{..} _extraArgs globalFlags = do
v
(fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
(flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
- (CondNode conf imps bs) <-
+ (CondNode (imps, conf) bs) <-
runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
readProjectLocalExtraConfig
v
(fromFlagOrDefault defaultProjectFileParser $ projectConfigProjectFileParser $ projectConfigShared cliConfig)
httpTransport
(distDirLayout baseCtx)
- when (not (null imps && null bs)) $ dieWithException v UnableToPerformInplaceUpdate
+ unless (null imps && null bs) $ dieWithException v UnableToPerformInplaceUpdate
return (baseCtx, conf <> cliConfig)
else return (baseCtx, cliConfig)
where
diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs
index 7eece5701f5..8f9bf63c1ba 100644
--- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs
+++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs
@@ -501,7 +501,7 @@ renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =
where
-- throw away the details and just list the deps that are needed
pkgids :: [PackageId]
- pkgids = nub . map packageId . concatMap snd $ brokenPackages
+ pkgids = nub . map packageId . concatMap (NE.toList . snd) $ brokenPackages
{-
++ "Syntax:\n"
diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs
index f750e439341..ac5bdd5ab1b 100644
--- a/cabal-install/src/Distribution/Client/CmdExec.hs
+++ b/cabal-install/src/Distribution/Client/CmdExec.hs
@@ -1,6 +1,9 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
-- |
-- Module : Distribution.Client.Exec
@@ -56,7 +59,8 @@ import Distribution.Client.ProjectPlanning
)
import qualified Distribution.Client.ProjectPlanning as Planning
import Distribution.Client.ProjectPlanning.Types
- ( dataDirsEnvironmentForPlan
+ ( Toolchain (..)
+ , dataDirsEnvironmentForPlan
)
import Distribution.Client.Setup
( GlobalFlags
@@ -104,6 +108,7 @@ import Prelude ()
import qualified Data.Map as M
import qualified Data.Set as S
import Distribution.Client.Errors
+import Distribution.Solver.Types.Stage
execCommand :: CommandUI (NixStyleFlags ())
execCommand =
@@ -152,6 +157,12 @@ execAction flags extraArgs globalFlags = do
baseCtx
(\plan -> return (plan, M.empty))
+ let toolchains = pkgConfigToolchains (elaboratedShared buildCtx)
+ -- We need the compiler and platform to set up the environment.
+ compilers = toolchainCompiler <$> toolchains
+ platforms = toolchainPlatform <$> toolchains
+ progdbs = toolchainProgramDb <$> toolchains
+
-- We use the build status below to decide what libraries to include in the
-- compiler environment, but we don't want to actually build anything. So we
-- pass mempty to indicate that nothing happened and we just want the current
@@ -166,7 +177,9 @@ execAction flags extraArgs globalFlags = do
-- Some dependencies may have executables. Let's put those on the PATH.
let extraPaths = pathAdditions baseCtx buildCtx
- pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx)
+ -- NOTE: only build-stage dependencies make sense here
+ pkgProgs = getStage progdbs Build
+ --
extraEnvVars =
dataDirsEnvironmentForPlan
(distDirLayout baseCtx)
@@ -181,7 +194,8 @@ execAction flags extraArgs globalFlags = do
-- point at the file.
-- In case ghc is too old to support environment files,
-- we pass the same info as arguments
- let compiler = pkgConfigCompiler $ elaboratedShared buildCtx
+ -- FIXME
+ let compiler = getStage compilers Host
envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)
case extraArgs of
[] -> dieWithException verbosity SpecifyAnExecutable
@@ -234,7 +248,9 @@ matchCompilerPath elaboratedShared program =
programPath program
`elem` (programPath <$> configuredCompilers)
where
- configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared
+ progdbs = toolchainProgramDb <$> pkgConfigToolchains elaboratedShared
+ -- FIXME
+ configuredCompilers = configuredPrograms (getStage progdbs Host)
-- | Execute an action with a temporary .ghc.environment file reflecting the
-- current environment. The action takes an environment containing the env
diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs
index 2f4ddaac8b4..eb799324f7c 100644
--- a/cabal-install/src/Distribution/Client/CmdFreeze.hs
+++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs
@@ -30,7 +30,7 @@ import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
import Distribution.Client.Targets
( UserConstraint (..)
- , UserConstraintScope (..)
+ , UserConstraintQualifier (..)
, UserQualifier (..)
)
import Distribution.Solver.Types.ConstraintSource
diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs
index 6e47fcd6a9c..6188ef3d46a 100644
--- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs
+++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs
@@ -18,7 +18,6 @@ import Control.Monad (mapM_)
import Distribution.Client.Errors
import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets)
-import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.Types.ConfiguredId (confInstId)
import Distribution.Client.Utils hiding (pvpize)
import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId)
@@ -28,6 +27,7 @@ import Distribution.Simple.Utils
import Distribution.Version
import Distribution.Client.Setup (GlobalFlags (..))
+import Distribution.Utils.LogProgress (runLogProgress)
-- Project orchestration imports
@@ -39,6 +39,7 @@ import Distribution.Client.ProjectFlags
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ScriptUtils
import Distribution.Client.TargetProblem
+import qualified Distribution.Compat.Graph as Graph
import Distribution.Simple.Command
import Distribution.Types.Component
import Distribution.Verbosity
@@ -114,11 +115,12 @@ genBoundsAction flags targetStrings globalFlags =
targetSelectors
-- Step 3: Prune the install plan to the targets.
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
let
-- Step 4a: Find the local packages from the install plan. These are the
@@ -130,8 +132,8 @@ genBoundsAction flags targetStrings globalFlags =
pkgVersionMap :: Map.Map ComponentId PackageIdentifier
pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan'))
- externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier)
- externalVersion pkg = (installedComponentId pkg, packageId pkg)
+ externalVersion :: WithStage InstalledPackageInfo -> (ComponentId, PackageIdentifier)
+ externalVersion (WithStage _stage pkg) = (installedComponentId pkg, packageId pkg)
localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier)
localVersion pkg = (elabComponentId pkg, packageId pkg)
@@ -139,7 +141,7 @@ genBoundsAction flags targetStrings globalFlags =
let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult]
genBoundsActionForPkg pkg =
-- Step 5: Match up the user specified targets with the local packages.
- case Map.lookup (installedUnitId pkg) targets of
+ case Map.lookup (Graph.nodeKey pkg) targets of
Nothing -> []
Just tgts ->
map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts
@@ -188,7 +190,8 @@ getBoundsForComponent tgt pkg pkgVersionMap =
let componentDeps = elabLibDependencies pkg
-- Match these up to package names, this is a list of Package name to versions.
-- Now just match that up with what the user wrote in the build-depends section.
- depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps
+ -- FIXME: I am not quite sure how this is supposed to work
+ depsWithVersions = mapMaybe (\(WithStage _stage cid, _) -> Map.lookup (confInstId cid) pkgVersionMap) componentDeps
isNeeded = hasElem needBounds . packageName
in boundsResult (Just (filter isNeeded depsWithVersions))
where
diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs
index f9be5763b3b..d741211f286 100644
--- a/cabal-install/src/Distribution/Client/CmdHaddock.hs
+++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
@@ -29,8 +30,12 @@ import Distribution.Client.ProjectConfig.Types
, ProjectConfig (..)
)
import Distribution.Client.ProjectOrchestration
-import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
( ElaboratedSharedConfig (..)
+ , Stage (..)
+ , Staged (..)
+ , Toolchain (..)
+ , getStage
)
import Distribution.Client.Setup
( GlobalFlags
@@ -70,6 +75,7 @@ import Distribution.Verbosity
)
import Distribution.Client.Errors
+import Distribution.Utils.LogProgress (runLogProgress)
import qualified System.Exit (exitSuccess)
newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool}
@@ -160,6 +166,7 @@ haddockAction relFlags targetStrings globalFlags = do
projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}}
| otherwise =
projCtx
+
absProjectConfig <- mkConfigAbsolute relProjectConfig
let baseCtx = relBaseCtx{projectConfig = absProjectConfig}
@@ -183,15 +190,20 @@ haddockAction relFlags targetStrings globalFlags = do
Nothing
targetSelectors
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionHaddock
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionHaddock
+ targets
+ elaboratedPlan
+
return (elaboratedPlan', targets)
printPlan verbosity baseCtx buildCtx
+ let toolchains = pkgConfigToolchains (elaboratedShared buildCtx)
+
+ -- TODO
progs <-
reconfigurePrograms
verbosity
@@ -200,14 +212,19 @@ haddockAction relFlags targetStrings globalFlags = do
-- we need to insert 'haddockProgram' before we reconfigure it,
-- otherwise 'set
. addKnownProgram haddockProgram
- . pkgConfigCompilerProgs
- . elaboratedShared
- $ buildCtx
+ -- TODO
+ . toolchainProgramDb
+ $ getStage toolchains Host
+
+ let toolchains' = Staged $ \case
+ Host -> (getStage toolchains' Host){toolchainProgramDb = progs}
+ Build -> getStage toolchains' Build
+
let buildCtx' =
buildCtx
{ elaboratedShared =
(elaboratedShared buildCtx)
- { pkgConfigCompilerProgs = progs
+ { pkgConfigToolchains = toolchains'
}
}
diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
index 320de351887..c191171891e 100644
--- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
+++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
@@ -35,11 +35,13 @@ import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
( ElaboratedConfiguredPackage (..)
, ElaboratedInstallPlan
+ , ElaboratedInstalledPackageInfo
, ElaboratedSharedConfig (..)
, TargetAction (..)
- )
-import Distribution.Client.ProjectPlanning.Types
- ( elabDistDirParams
+ , Toolchain (..)
+ , WithStage (..)
+ , elabDistDirParams
+ , getStage
)
import Distribution.Client.ScriptUtils
( AcceptNoTargets (..)
@@ -71,18 +73,11 @@ import Distribution.Simple.Flag
, pattern Flag
, pattern NoFlag
)
-import Distribution.Simple.Haddock (createHaddockIndex)
+
+-- import Distribution.Simple.Haddock (createHaddockIndex)
import Distribution.Simple.InstallDirs
( toPathTemplate
)
-import Distribution.Simple.Program.Builtin
- ( haddockProgram
- )
-import Distribution.Simple.Program.Db
- ( addKnownProgram
- , reconfigurePrograms
- , requireProgramVersion
- )
import Distribution.Simple.Setup
( HaddockFlags (..)
, HaddockProjectFlags (..)
@@ -103,8 +98,7 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su
import Distribution.Types.PackageId (pkgName)
import Distribution.Types.PackageName (unPackageName)
import Distribution.Types.UnitId (unUnitId)
-import Distribution.Types.Version (mkVersion)
-import Distribution.Types.VersionRange (orLaterVersion)
+import Distribution.Utils.LogProgress (runLogProgress)
import Distribution.Verbosity as Verbosity
( defaultVerbosityHandles
, mkVerbosity
@@ -156,11 +150,12 @@ haddockProjectAction flags _extraArgs globalFlags = do
Nothing
targetSelectors
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
return (elaboratedPlan', targets)
let elaboratedPlan :: ElaboratedInstallPlan
@@ -169,27 +164,29 @@ haddockProjectAction flags _extraArgs globalFlags = do
sharedConfig :: ElaboratedSharedConfig
sharedConfig = elaboratedShared buildCtx
- pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+ pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage]
pkgs = matchingPackages elaboratedPlan
- progs <-
- reconfigurePrograms
- verbosity
- (haddockProjectProgramPaths flags)
- (haddockProjectProgramArgs flags)
- -- we need to insert 'haddockProgram' before we reconfigure it,
- -- otherwise 'set
- . addKnownProgram haddockProgram
- . pkgConfigCompilerProgs
- $ sharedConfig
- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
-
- _ <-
- requireProgramVersion
- verbosity
- haddockProgram
- (orLaterVersion (mkVersion [2, 26, 1]))
- progs
+ -- TODO
+ -- progs <-
+ -- reconfigurePrograms
+ -- verbosity
+ -- (haddockProjectProgramPaths flags)
+ -- (haddockProjectProgramArgs flags)
+ -- -- we need to insert 'haddockProgram' before we reconfigure it,
+ -- -- otherwise 'set
+ -- . addKnownProgram haddockProgram
+ -- . pkgConfigCompilerProgs
+ -- $ sharedConfig
+ -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
+ let sharedConfig' = sharedConfig
+
+ -- _ <-
+ -- requireProgramVersion
+ -- verbosity
+ -- haddockProgram
+ -- (orLaterVersion (mkVersion [2, 26, 1]))
+ -- progs
--
-- Build project; we need to build dependencies.
@@ -217,7 +214,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
case pkg of
- Left package | localStyle -> do
+ Left (WithStage _ package) | localStyle -> do
let packageName = unPackageName (pkgName $ sourcePackageId package)
destDir = outputDir packageName
fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
@@ -304,10 +301,12 @@ haddockProjectAction flags _extraArgs globalFlags = do
False -> do
let pkg_descr = elabPkgDescription package
unitId = unUnitId (elabUnitId package)
+ compilers = toolchainCompiler <$> pkgConfigToolchains sharedConfig'
+ compiler = getStage compilers (elabStage package)
packageDir =
storePackageDirectory
(cabalStoreDirLayout cabalLayout)
- (pkgConfigCompiler sharedConfig')
+ compiler
(elabUnitId package)
-- TODO: use `InstallDirTemplates`
docDir = packageDir "share" "doc" "html"
@@ -327,7 +326,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
-- generate index, content, etc.
--
- let (missingHaddocks, packageInfos') = partitionEithers packageInfos
+ let (missingHaddocks, _packageInfos') = partitionEithers packageInfos
when (not (null missingHaddocks)) $ do
warn verbosity "missing haddocks for some packages from the store"
-- Show the package list if `-v1` is passed; it's usually a long list.
@@ -336,28 +335,31 @@ haddockProjectAction flags _extraArgs globalFlags = do
-- `documentation: True` in the global config).
info verbosity (intercalate "\n" missingHaddocks)
- let flags' =
- flags
- { haddockProjectDir = Flag outputDir
- , haddockProjectInterfaces =
- Flag
- [ ( interfacePath
- , Just url
- , Just url
- , visibility
- )
- | (url, interfacePath, visibility) <- packageInfos'
- ]
- , haddockProjectUseUnicode = NoFlag
- }
- createHaddockIndex
- verbosity
- (pkgConfigCompilerProgs sharedConfig')
- (pkgConfigCompiler sharedConfig')
- (pkgConfigPlatform sharedConfig')
- Nothing
- flags'
+ warn verbosity "createHaddockIndex not implemented"
where
+ -- let flags' =
+ -- flags
+ -- { haddockProjectDir = Flag outputDir
+ -- , haddockProjectInterfaces =
+ -- Flag
+ -- [ ( interfacePath
+ -- , Just url
+ -- , Just url
+ -- , visibility
+ -- )
+ -- | (url, interfacePath, visibility) <- packageInfos'
+ -- ]
+ -- , haddockProjectUseUnicode = NoFlag
+ -- }
+ -- -- NOTE: this lives in Cabal
+ -- createHaddockIndex
+ -- verbosity
+ -- (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains sharedConfig')
+ -- (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig')
+ -- (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig')
+ -- Nothing
+ -- flags'
+
-- build all packages with appropriate haddock flags
commonFlags = haddockProjectCommonFlags flags
@@ -446,7 +448,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
matchingPackages
:: ElaboratedInstallPlan
- -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+ -> [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage]
matchingPackages =
fmap (foldPlanPackage Left Right)
. InstallPlan.toList
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
index cd75f418262..e06d51ca1e0 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -65,7 +65,8 @@ import Distribution.Client.NixStyleOptions
, nixStyleOptions
)
import Distribution.Client.ProjectConfig
- ( ProjectPackageLocation (..)
+ ( ProjectConfigToolchain (..)
+ , ProjectPackageLocation (..)
, fetchAndReadSourcePackages
, projectConfigWithBuilderRepoContext
, resolveBuildTimeSettings
@@ -87,10 +88,10 @@ import Distribution.Client.ProjectConfig.Types
)
import Distribution.Client.ProjectFlags (ProjectFlags (..))
import Distribution.Client.ProjectPlanning
- ( storePackageInstallDirs'
- )
-import Distribution.Client.ProjectPlanning.Types
( ElaboratedInstallPlan
+ , ElaboratedPlanPackage
+ , Stage (..)
+ , storePackageInstallDirs'
)
import Distribution.Client.RebuildMonad
( runRebuild
@@ -111,6 +112,7 @@ import Distribution.Client.Types
import Distribution.Client.Types.OverwritePolicy
( OverwritePolicy (..)
)
+import qualified Distribution.Compat.Graph as Graph
import Distribution.Package
( Package (..)
, PackageName
@@ -213,6 +215,9 @@ import Distribution.Types.VersionRange
import Distribution.Utils.Generic
( writeFileAtomic
)
+import Distribution.Utils.LogProgress
+ ( runLogProgress
+ )
import Distribution.Verbosity
( lessVerbose
, modifyVerbosityFlags
@@ -410,12 +415,15 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
}
, projectConfigShared =
ProjectConfigShared
- { projectConfigHcFlavor
- , projectConfigHcPath
- , projectConfigHcPkg
+ { projectConfigToolchain =
+ ProjectConfigToolchain
+ { projectConfigHcFlavor
+ , projectConfigHcPath
+ , projectConfigHcPkg
+ , projectConfigPackageDBs
+ }
, projectConfigStoreDir
, projectConfigProgPathExtra
- , projectConfigPackageDBs
}
, projectConfigLocalPackages =
PackageConfig
@@ -468,7 +476,6 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
fetchAndReadSourcePackages
verbosity
distDirLayout
- (Just compiler)
(projectConfigShared config)
(projectConfigBuildOnly config)
[ProjectPackageRemoteTarball uri | uri <- uris]
@@ -559,7 +566,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do
let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags
actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg
- traverse_ actionOnExe . Map.toList $ targetsMap buildCtx
+ traverse_ actionOnExe . Map.toList $ filterTargetsWithStage Host $ targetsMap buildCtx
withProject
:: Verbosity
@@ -778,7 +785,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector
localPkgs = sdistize <$> localPackages baseCtx
- gatherTargets :: UnitId -> TargetSelector
+ gatherTargets :: Graph.Key ElaboratedPlanPackage -> TargetSelector
gatherTargets targetId = TargetPackageNamed pkgName targetFilter
where
targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
@@ -823,7 +830,7 @@ partitionToKnownTargetsAndHackagePackages
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
- -> IO (TargetsMap, [PackageName])
+ -> IO (TargetsMapS, [PackageName])
partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
let mTargets =
resolveTargetsFromSolver
@@ -852,7 +859,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
dieWithException verbosity $ UnknownPackage (unPackageName hn) (("- " ++) . unPackageName . fst <$> xs)
_ -> return ()
- when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'
+ unless (null errs') $ reportBuildTargetProblems verbosity errs'
let
targetSelectors' = flip filter targetSelectors $ \case
@@ -893,15 +900,18 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do
Nothing
targetSelectors
- let prunedToTargetsElaboratedPlan =
- pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
+ prunedToTargetsElaboratedPlan <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
+
prunedElaboratedPlan <-
if buildSettingOnlyDeps (buildSettings baseCtx)
- then
- either (reportCannotPruneDependencies verbosity) return $
- pruneInstallPlanToDependencies
- (Map.keysSet targets)
- prunedToTargetsElaboratedPlan
+ then do
+ case pruneInstallPlanToDependencies (Map.keysSet targets) prunedToTargetsElaboratedPlan of
+ Left err ->
+ reportCannotPruneDependencies verbosity err
+ Right elaboratedPlan'' ->
+ runLogProgress verbosity $ InstallPlan.new' elaboratedPlan''
else return prunedToTargetsElaboratedPlan
return (prunedElaboratedPlan, targets)
@@ -999,7 +1009,7 @@ installLibraries
ordNub $
globalEntries
++ envEntries
- ++ entriesForLibraryComponents (targetsMap buildCtx)
+ ++ entriesForLibraryComponents (filterTargetsWithStage Host $ targetsMap buildCtx)
contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
createDirectoryIfMissing True (takeDirectory envFile)
writeFileAtomic envFile (BS.pack contents')
diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs
index d849fbfb535..cbfbf5e24b0 100644
--- a/cabal-install/src/Distribution/Client/CmdLegacy.hs
+++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@@ -14,7 +13,8 @@ import Distribution.Client.Sandbox
)
import qualified Distribution.Client.Setup as Client
import Distribution.Client.SetupWrapper
- ( SetupScriptOptions (..)
+ ( SetupRunnerArgs (NotInLibrary)
+ , SetupScriptOptions (..)
, defaultSetupScriptOptions
, setupWrapper
)
@@ -46,7 +46,7 @@ wrapperCmd
-> (flags -> Setup.CommonSetupFlags)
-> CommandSpec (Client.GlobalFlags -> IO ())
wrapperCmd ui getCommonFlags =
- CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand
+ CommandSpec ui (`wrapperAction` getCommonFlags) NormalCommand
wrapperAction
:: Monoid flags
@@ -84,6 +84,7 @@ wrapperAction command getCommonFlags =
getCommonFlags
(const (return flags))
(const extraArgs)
+ NotInLibrary
--
diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs
index b6bdf4b9339..31ac72dad98 100644
--- a/cabal-install/src/Distribution/Client/CmdListBin.hs
+++ b/cabal-install/src/Distribution/Client/CmdListBin.hs
@@ -48,7 +48,6 @@ import Distribution.Client.TargetProblem (TargetProblem (..))
import Distribution.Simple.BuildPaths (dllExtension, exeExtension)
import Distribution.Simple.Command (CommandUI (..))
import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText)
-import Distribution.System (Platform)
import Distribution.Types.ComponentName (showComponentName)
import Distribution.Types.UnitId (UnitId)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
@@ -61,6 +60,7 @@ import Distribution.Client.Errors
import qualified Distribution.Client.InstallPlan as IP
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Solver.Types.ComponentDeps as CD
+import Distribution.Utils.LogProgress (runLogProgress)
-------------------------------------------------------------------------------
-- Command
@@ -128,11 +128,13 @@ listbinAction flags args globalFlags = do
)
targets
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
+
return (elaboratedPlan', targets)
(selectedUnitId, selectedComponent) <-
@@ -204,8 +206,8 @@ listbinAction flags args globalFlags = do
| s == selectedComponent -> [flib_file' s]
_ -> []
- plat :: Platform
- plat = pkgConfigPlatform elaboratedSharedConfig
+ Toolchain{toolchainPlatform = plat} =
+ getStage (pkgConfigToolchains elaboratedSharedConfig) (elabStage elab)
-- here and in PlanOutput,
-- use binDirectoryFor?
@@ -225,7 +227,7 @@ listbinAction flags args globalFlags = do
-- Target Problem: the very similar to CmdRun
-------------------------------------------------------------------------------
-singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
+singleComponentOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName)
singleComponentOrElse action targetsMap =
case Set.toList . distinctTargetComponents $ targetsMap of
[(unitId, CExeName component)] -> return (unitId, component)
@@ -317,7 +319,7 @@ data ListBinProblem
| -- | A single 'TargetSelector' matches multiple targets
TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
| -- | Multiple 'TargetSelector's match multiple targets
- TargetProblemMultipleTargets TargetsMap
+ TargetProblemMultipleTargets TargetsMapS
| -- | The 'TargetSelector' refers to a component that is not an executable
TargetProblemComponentNotRightKind PackageId ComponentName
| -- | Asking to run an individual file or module is not supported
@@ -334,7 +336,7 @@ matchesMultipleProblem selector targets =
CustomTargetProblem $
TargetProblemMatchesMultiple selector targets
-multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem
+multipleTargetsProblem :: TargetsMapS -> TargetProblem ListBinProblem
multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem
@@ -377,12 +379,8 @@ renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =
++ renderTargetSelector targetSelector
++ " which includes "
++ renderListCommaAnd
- ( ("the " ++)
- <$> showComponentName
- <$> availableTargetComponentName
- <$> foldMap
- (\kind -> filterTargetsKind kind targets)
- [ExeKind, TestKind, BenchKind]
+ ( (("the " ++) <$> showComponentName) . availableTargetComponentName
+ <$> foldMap (`filterTargetsKind` targets) [ExeKind, TestKind, BenchKind]
)
++ "."
renderListBinProblem (TargetProblemMultipleTargets selectorMap) =
diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs
index 1d7cf38093b..d873908a08a 100644
--- a/cabal-install/src/Distribution/Client/CmdOutdated.hs
+++ b/cabal-install/src/Distribution/Client/CmdOutdated.hs
@@ -264,7 +264,7 @@ outdatedAction flags targetStrings globalFlags =
deps
sourcePkgDb
(ListOutdatedSettings ignorePred minorPred)
- when (not quiet) $
+ unless quiet $
showResult verbosity outdatedDeps simpleOutput
when (exitCode && (not . null $ outdatedDeps)) exitFailure
where
@@ -281,14 +281,14 @@ outdatedAction flags targetStrings globalFlags =
exitCode = fromFlagOrDefault quiet outdatedExitCode
ignorePred =
let ignoreSet = S.fromList outdatedIgnore
- in \pkgname -> pkgname `S.member` ignoreSet
+ in (`S.member` ignoreSet)
minorPred = case outdatedMinor of
Nothing -> const False
Just IgnoreMajorVersionBumpsNone -> const False
Just IgnoreMajorVersionBumpsAll -> const True
Just (IgnoreMajorVersionBumpsSome pkgs) ->
let minorSet = S.fromList pkgs
- in \pkgname -> pkgname `S.member` minorSet
+ in (`S.member` minorSet)
reportOutdatedTargetProblem :: Verbosity -> [TargetProblem'] -> IO a
reportOutdatedTargetProblem verbosity problems =
@@ -300,7 +300,7 @@ showResult :: Verbosity -> [OutdatedDependency] -> Bool -> IO ()
showResult verbosity outdatedDeps simpleOutput =
if not . null $ outdatedDeps
then do
- when (not simpleOutput) $
+ unless simpleOutput $
notice verbosity "Outdated dependencies:"
if simpleOutput
then -- Simple output just prints package names, one per line
diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs
index d5713a8b12c..12aadd25634 100644
--- a/cabal-install/src/Distribution/Client/CmdPath.hs
+++ b/cabal-install/src/Distribution/Client/CmdPath.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
-- |
-- Module : Distribution.Client.CmdPath
@@ -76,6 +77,7 @@ import Distribution.Simple.Program
import Distribution.Simple.Utils
( die'
, dieWithException
+ , warn
, withOutputMarker
, wrapText
)
@@ -236,7 +238,7 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF
, pathDirectories = Flag [minBound .. maxBound]
}
else pathFlags'
- when (not $ null cliTargetStrings) $
+ unless (null cliTargetStrings) $
dieWithException verbosity CmdPathAcceptsNoTargets
when (buildSettingDryRun (buildSettings baseCtx)) $
dieWithException verbosity CmdPathCommandDoesn'tSupportDryRun
@@ -245,17 +247,13 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF
if not $ fromFlagOrDefault False (pathCompiler pathFlags)
then pure Nothing
else do
- (compiler, _, progDb) <-
- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
- configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
- compilerProg <- requireCompilerProg verbosity compiler
- (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb
-
- let compilerInfo' =
- mkCompilerInfo configuredCompilerProg compiler $
- cabalStoreDirLayout (cabalDirLayout baseCtx)
-
- pure $ Just compilerInfo'
+ let projectRoot = distProjectRootDirectory (distDirLayout baseCtx)
+ toolchains <- runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (projectConfig baseCtx)
+ warn verbosity "WIP: Assuming host toolchain, result might be wrong"
+ let Toolchain{..} = getStage toolchains Host
+ compilerProg <- requireCompilerProg verbosity toolchainCompiler
+ (configuredCompilerProg, _) <- requireProgram verbosity compilerProg toolchainProgramDb
+ pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler (cabalStoreDirLayout $ cabalDirLayout baseCtx)
paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do
t <- getPathLocation verbosity baseCtx p
diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs
index e27a4d18642..ac00434a8b8 100644
--- a/cabal-install/src/Distribution/Client/CmdRepl.hs
+++ b/cabal-install/src/Distribution/Client/CmdRepl.hs
@@ -26,7 +26,8 @@ import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L
import Distribution.Client.CmdErrorMessages
- ( Plural (..)
+ ( ComponentKind (..)
+ , Plural (..)
, componentKind
, renderComponentKind
, renderListCommaAnd
@@ -56,9 +57,13 @@ import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
( ElaboratedInstallPlan
, ElaboratedSharedConfig (..)
+ , Stage (..)
+ , WithStage
+ , getStage
)
import Distribution.Client.ProjectPlanning.Types
- ( elabOrderExeDependencies
+ ( Toolchain (..)
+ , elabOrderExeDependencies
, showElaboratedInstallPlan
)
import Distribution.Client.ScriptUtils
@@ -81,7 +86,7 @@ import Distribution.Client.TargetProblem
)
import Distribution.Client.Targets
( UserConstraint (..)
- , UserConstraintScope (..)
+ , UserConstraintQualifier (..)
)
import Distribution.Client.Types
( PackageSpecifier (..)
@@ -93,7 +98,6 @@ import Distribution.Compiler
import Distribution.Package
( Package (..)
, UnitId
- , installedUnitId
, mkPackageName
, packageName
)
@@ -158,6 +162,9 @@ import Distribution.Types.VersionRange
import Distribution.Utils.Generic
( safeHead
)
+import Distribution.Utils.LogProgress
+ ( runLogProgress
+ )
import Distribution.Verbosity
( lessVerbose
, modifyVerbosityFlags
@@ -185,11 +192,12 @@ import Distribution.Client.ReplFlags
, topReplOptions
)
import Distribution.Compat.Binary (decode)
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.Types.PackageName.Magic (fakePackageId)
import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag)
import Distribution.Simple.Program.Builtin (ghcProgram)
import Distribution.Simple.Program.Db (requireProgram)
import Distribution.Simple.Program.Types
-import Distribution.Types.PackageName.Magic (fakePackageId)
import System.Directory
( doesFileExist
, getCurrentDirectory
@@ -360,7 +368,7 @@ resolveGlobalTarget flags@NixStyleFlags{extraFlags = ReplFlags{..}} targetString
sourcePackage =
fakeProjectSourcePackage projectRoot
& ( (lSrcpkgDescription . L.condLibrary)
- ?~ (CondNode library [baseDep] [])
+ ?~ (CondNode library [])
)
library = emptyLibrary{libBuildInfo = lBuildInfo}
lBuildInfo =
@@ -443,13 +451,14 @@ targetedRepl
-- especially in the no-project case.
withInstallPlan (modifyVerbosityFlags lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do
-- targets should be non-empty map, but there's no NonEmptyMap yet.
- targets <- validatedTargets' (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors
-
+ let Toolchain{toolchainCompiler = compiler} = getStage (pkgConfigToolchains sharedConfig) Build
+ -- FIXME there is total confusion here about who is filtering for the stage
+ targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors
let
- (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
- originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId
- oci = OriginalComponentInfo unitId originalDeps
- pkgId = maybe (error $ "cannot find " ++ prettyShow unitId) packageId (InstallPlan.lookup elaboratedPlan unitId)
+ (key, _uid) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
+ originalDeps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan key
+ oci = OriginalComponentInfo key originalDeps
+ pkgId = fromMaybe (error $ "cannot find " ++ prettyShow key) $ packageId <$> InstallPlan.lookup elaboratedPlan key
baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx'
return (Just oci, baseCtx'')
@@ -462,25 +471,23 @@ targetedRepl
-- In addition, to avoid a *third* trip through the solver, we are
-- replicating the second half of 'runProjectPreBuildPhase' by hand
-- here.
- (buildCtx, compiler, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $
+ (buildCtx, compiler, progdb, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $
\elaboratedPlan elaboratedShared' -> do
let ProjectBaseContext{..} = baseCtx''
+ -- TODO: This mightr not make sense
+ Toolchain{..} = getStage (pkgConfigToolchains elaboratedShared') Host
-- Recalculate with updated project.
- targets <- validatedTargets' (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors
+ targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors
- let
- elaboratedPlan' =
- -- Guard against pruning with empty targets and failing an assertion
- -- within pruneInstallPlanToTargets.
- if null targets
- then elaboratedPlan
- else
- pruneInstallPlanToTargets
- TargetActionRepl
- targets
- elaboratedPlan
- includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionRepl
+ targets
+ elaboratedPlan
+
+ let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags)
pkgsBuildStatus <-
rebuildTargetsDryRun
@@ -504,13 +511,11 @@ targetedRepl
, targetsMap = targets
}
- ElaboratedSharedConfig{pkgConfigCompiler = compiler, pkgConfigPlatform = platform} = elaboratedShared'
-
repl_flags = case originalComponent of
Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
Nothing -> []
- return (buildCtx, compiler, platform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets)
+ return (buildCtx, toolchainCompiler, toolchainProgramDb, toolchainPlatform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets)
-- Multi Repl implementation see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for
-- a high-level overview about how everything fits together.
@@ -522,7 +527,7 @@ targetedRepl
-- into the multi-out directory.
replOpts'' <- case targetCtx of
ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir}
- _ -> usingGhciScript compiler projectRoot replOpts'
+ _ -> usingGhciScript projectRoot replOpts'
let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
printPlan verbosity baseCtx'' buildCtx'
@@ -545,7 +550,7 @@ targetedRepl
-- HACK: Just combine together all env overrides, placing the most common things last
-- ghc program with overridden PATH
- (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx'))
+ (ghcProg, _) <- requireProgram verbosity ghcProgram progdb
let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]}
-- Find what the unit files are, and start a repl based on all the response
@@ -591,26 +596,48 @@ targetedRepl
-- single target repl
replOpts'' <- case targetCtx of
ProjectContext -> return replOpts'
- _ -> usingGhciScript compiler projectRoot replOpts'
+ _ -> usingGhciScript projectRoot replOpts'
let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
printPlan verbosity baseCtx'' buildCtx'
buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx'
runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes
- where
- projectRoot = distProjectRootDirectory $ distDirLayout ctx
- distDir = distDirectory $ distDirLayout ctx
+ where
+ combine_search_paths paths =
+ foldl' go Map.empty paths
+ where
+ go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s)
+ go m _ = m
+
+ projectRoot = distProjectRootDirectory $ distDirLayout ctx
+ distDir = distDirectory $ distDirLayout ctx
+ verbosity = cfgVerbosity normal flags
+ tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags
+
+ -- FIXME: the compiler depends on the stage!!
+ validatedTargets ctx compiler elaboratedPlan targetSelectors = do
+ let multi_repl_enabled = multiReplDecision ctx compiler replFlags
+ -- Interpret the targets on the command line as repl targets
+ -- (as opposed to say build or haddock targets).
+ targets <-
+ either (reportTargetProblems verbosity) return $
+ resolveTargetsFromSolver
+ (selectPackageTargets multi_repl_enabled)
+ selectComponentTarget
+ elaboratedPlan'
+ Nothing
+ selectors
- combine_search_paths paths =
- foldl' go Map.empty paths
- where
- go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s)
- go m _ = m
+ -- Reject multiple targets, or at least targets in different
+ -- components. It is ok to have two module/file targets in the
+ -- same component, but not two that live in different components.
+ when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $
+ reportTargetProblems
+ verbosity
+ [multipleTargetsProblem multi_repl_enabled targets]
- verbosity = cfgVerbosity normal flags
- tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags
- validatedTargets' = validatedTargets verbosity replFlags
+ return targets
withCtx :: NixStyleFlags a -> [String] -> GlobalFlags -> TargetsAction [TargetSelector] b -> IO b
withCtx flags targetStrings globalFlags =
@@ -673,7 +700,7 @@ validatedTargets
-> Compiler
-> ElaboratedInstallPlan
-> [TargetSelector]
- -> IO TargetsMap
+ -> IO TargetsMapS
validatedTargets verbosity replFlags ctx compiler elaboratedPlan targetSelectors = do
let multi_repl_enabled = multiReplDecision ctx compiler replFlags
-- Interpret the targets on the command line as repl targets (as opposed to
@@ -702,8 +729,8 @@ minMultipleHomeUnitsVersion :: Version
minMultipleHomeUnitsVersion = mkVersion [9, 4]
data OriginalComponentInfo = OriginalComponentInfo
- { ociUnitId :: UnitId
- , ociOriginalDeps :: [UnitId]
+ { ociUnitId :: WithStage UnitId
+ , ociOriginalDeps :: [WithStage UnitId]
}
deriving (Show)
@@ -738,18 +765,25 @@ addDepsToProjectTarget deps pkgId ctx =
generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String]
generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags
where
- exeDeps :: [UnitId]
+ exeDeps :: [WithStage UnitId]
exeDeps =
foldMap
(InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)
(InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])
- deps, deps', trans, trans' :: [UnitId]
- flags :: [String]
- deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
+ deps :: [WithStage UnitId]
+ deps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan ociUnitId
+
+ deps' :: [WithStage UnitId]
deps' = deps \\ ociOriginalDeps
- trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
+
+ trans :: [WithStage UnitId]
+ trans = Graph.nodeKey <$> InstallPlan.dependencyClosure elaboratedPlan deps'
+
+ trans' :: [WithStage UnitId]
trans' = trans \\ ociOriginalDeps
+
+ flags :: [String]
flags =
fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $
if includeTransitive then trans' else deps'
@@ -761,20 +795,13 @@ generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = f
-- so we need to tell ghci to change back to the correct directory.
--
-- The @-ghci-script@ flag is path to the ghci script responsible for changing to the
--- correct directory. Only works on GHC >= 7.6, though. 🙁
-usingGhciScript :: Compiler -> FilePath -> ReplOptions -> IO ReplOptions
-usingGhciScript compiler projectRoot replOpts
- | compilerCompatVersion GHC compiler >= Just minGhciScriptVersion = do
- let ghciScriptPath = projectRoot "setcwd.ghci"
- cwd <- getCurrentDirectory
- writeFile ghciScriptPath (":cd " ++ cwd)
- return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :)
- | otherwise = return replOpts
-
--- | First version of GHC where GHCi supported the flag we need.
--- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html
-minGhciScriptVersion :: Version
-minGhciScriptVersion = mkVersion [7, 6]
+-- correct directory.
+usingGhciScript :: FilePath -> ReplOptions -> IO ReplOptions
+usingGhciScript projectRoot replOpts = do
+ let ghciScriptPath = projectRoot "setcwd.ghci"
+ cwd <- getCurrentDirectory
+ writeFile ghciScriptPath (":cd " ++ cwd)
+ return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :)
-- | This defines what a 'TargetSelector' means for the @repl@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
@@ -901,7 +928,7 @@ selectComponentTarget = selectComponentTargetBasic
data ReplProblem
= TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()]
| -- | Multiple 'TargetSelector's match multiple targets
- TargetProblemMultipleTargets MultiReplDecision TargetsMap
+ TargetProblemMultipleTargets MultiReplDecision TargetsMapS
deriving (Eq, Show)
-- | The various error conditions that can occur when matching a
@@ -918,7 +945,7 @@ matchesMultipleProblem decision targetSelector targetsExesBuildable =
multipleTargetsProblem
:: MultiReplDecision
- -> TargetsMap
+ -> TargetsMapS
-> ReplTargetProblem
multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision
diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs
index a5389c68d1b..8d0be986894 100644
--- a/cabal-install/src/Distribution/Client/CmdRun.hs
+++ b/cabal-install/src/Distribution/Client/CmdRun.hs
@@ -54,6 +54,7 @@ import qualified Distribution.Client.ProjectOrchestration as Orchestration (targ
import Distribution.Client.ProjectPlanning
( ElaboratedConfiguredPackage (..)
, ElaboratedInstallPlan
+ , WithStage (..)
, binDirectoryFor
)
import Distribution.Client.ProjectPlanning.Types
@@ -61,7 +62,6 @@ import Distribution.Client.ProjectPlanning.Types
, dataDirsEnvironmentForPlan
, elabExeDependencyPaths
)
-
import Distribution.Client.ScriptUtils
( AcceptNoTargets (..)
, TargetContext (..)
@@ -124,6 +124,7 @@ import Distribution.Types.UnqualComponentName
( UnqualComponentName
, unUnqualComponentName
)
+import Distribution.Utils.LogProgress (runLogProgress)
import Distribution.Utils.NubList
( fromNubList
)
@@ -200,7 +201,9 @@ runCommand =
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-runAction flags targetAndArgs globalFlags =
+runAction flags targetAndArgs globalFlags = do
+ fullArgs <- getFullArgs
+ let (targetStr, args) = splitTargetAndArgs fullArgs targetAndArgs
withContextAndSelectors (cfgVerbosity normal flags) RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
(baseCtx, defaultVerbosity) <- case targetCtx of
ProjectContext -> return (ctx, normal)
@@ -214,7 +217,6 @@ runAction flags targetAndArgs globalFlags =
when (buildSettingOnlyDeps (buildSettings baseCtx)) $
dieWithException verbosity NoSupportForRunCommand
- fullArgs <- getFullArgs
when (occursOnlyOrBefore fullArgs "+RTS" "--") $
warn verbosity $
giveRTSWarning "run"
@@ -245,11 +247,13 @@ runAction flags targetAndArgs globalFlags =
)
targets
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
+
return (elaboratedPlan', targets)
(selectedUnitId, selectedComponent) <-
@@ -354,8 +358,62 @@ runAction flags targetAndArgs globalFlags =
(distDirLayout baseCtx)
elaboratedPlan
}
- where
- (targetStr, args) = splitAt 1 targetAndArgs
+
+-- | Split @cabal run@ arguments (@exe cmd@ arguments in the examples) into
+-- target selectors and target executable arguments.
+--
+-- When a target is given it appears in both lists:
+--
+-- >>> splitTargetAndArgs ["exe", "cmd", "target"] ["target"]
+-- (["target"],[])
+--
+-- The @+RTS@ argument is passed to the executable so only appears in the first
+-- list:
+--
+-- >>> splitTargetAndArgs ["exe", "cmd", "target", "+RTS"] ["target"]
+-- (["target"],[])
+--
+-- The @--@ follows the @+RTS@ argument, so @+RTS@ is passed to the executable
+-- and only appears in the first list:
+--
+-- >>> splitTargetAndArgs ["exe", "cmd", "target", "+RTS", "--"] ["target"]
+-- (["target"],[])
+--
+-- The @--@ precedes the @+RTS@ argument, so @+RTS@ is included in the
+-- 'targetAndArgs' list as well:
+--
+-- >>> splitTargetAndArgs ["exe", "cmd", "target", "--", "+RTS"] ["target", "+RTS"]
+-- (["target"],["+RTS"])
+--
+-- Same examples as above but when no target is given:
+--
+-- >>> splitTargetAndArgs ["exe", "cmd"] []
+-- ([],[])
+-- >>> splitTargetAndArgs ["exe", "cmd", "+RTS"] []
+-- ([],[])
+-- >>> splitTargetAndArgs ["exe", "cmd", "+RTS", "--"] []
+-- ([],[])
+-- >>> splitTargetAndArgs ["exe", "cmd", "--", "+RTS"] ["+RTS"]
+-- ([],["+RTS"])
+splitTargetAndArgs
+ :: [String]
+ -- ^ Full command line arguments, the original command line from
+ -- 'getFullArgs', which is only used to detect whether a @--@ separator was
+ -- present so that @cabal run -- ...@ keeps the target empty.
+ -> [String]
+ -- ^ The second argument is the parser-produced list that combines targets and
+ -- their arguments. These arguments do not include those passed to @cabal@
+ -- such as @+RTS@ preceding the @--@ separator.
+ -> ([String], [String])
+splitTargetAndArgs fullArgs targetAndArgs = case dropWhile (/= "--") fullArgs of
+ ("--" : exeArgs) ->
+ -- targetAndArgs contains targets (>=0) and args; exeArgs contains only args; so
+ -- the difference (>=0) is the number of targets
+ let numTargets = length targetAndArgs - length exeArgs
+ in splitAt numTargets targetAndArgs
+ _ ->
+ -- No '--': first element (if any) is the target.
+ splitAt 1 targetAndArgs
-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was
-- invoked as a script interpreter, i.e. via
@@ -383,7 +441,7 @@ handleShebang :: FilePath -> [String] -> IO ()
handleShebang script args =
runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags
-singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
+singleExeOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName)
singleExeOrElse action targetsMap =
case Set.toList . distinctTargetComponents $ targetsMap of
[(unitId, CExeName component)] -> return (unitId, component)
@@ -395,19 +453,20 @@ singleExeOrElse action targetsMap =
-- 'ElaboratedConfiguredPackage's that match the specified
-- 'UnitId'.
matchingPackagesByUnitId
- :: UnitId
+ :: WithStage UnitId
-> ElaboratedInstallPlan
-> [ElaboratedConfiguredPackage]
-matchingPackagesByUnitId uid =
- mapMaybe
- ( foldPlanPackage
- (const Nothing)
- ( \x ->
- if elabUnitId x == uid
- then Just x
- else Nothing
- )
- )
+matchingPackagesByUnitId (WithStage s uid) =
+ catMaybes
+ . fmap
+ ( foldPlanPackage
+ (const Nothing)
+ ( \x ->
+ if elabUnitId x == uid && elabStage x == s
+ then Just x
+ else Nothing
+ )
+ )
. toList
-- | This defines what a 'TargetSelector' means for the @run@ command.
@@ -492,7 +551,7 @@ data RunProblem
| -- | A single 'TargetSelector' matches multiple targets
TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
| -- | Multiple 'TargetSelector's match multiple targets
- TargetProblemMultipleTargets TargetsMap
+ TargetProblemMultipleTargets TargetsMapS
| -- | The 'TargetSelector' refers to a component that is not an executable
TargetProblemComponentNotExe PackageId ComponentName
| -- | Asking to run an individual file or module is not supported
@@ -509,7 +568,7 @@ matchesMultipleProblem selector targets =
CustomTargetProblem $
TargetProblemMatchesMultiple selector targets
-multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem
+multipleTargetsProblem :: TargetsMapS -> TargetProblem RunProblem
multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem
@@ -556,9 +615,7 @@ renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) =
<$> zip
["executables", "test-suites", "benchmarks"]
( filter (not . null) . map sortNub $
- map (componentNameRaw . availableTargetComponentName)
- <$> (`filterTargetsKind` targets)
- <$> [ExeKind, TestKind, BenchKind]
+ (map (componentNameRaw . availableTargetComponentName) . (`filterTargetsKind` targets) <$> [ExeKind, TestKind, BenchKind])
)
)
renderRunProblem (TargetProblemMultipleTargets selectorMap) =
diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs
index b5e332ceaeb..9d05bba076b 100644
--- a/cabal-install/src/Distribution/Client/CmdTarget.hs
+++ b/cabal-install/src/Distribution/Client/CmdTarget.hs
@@ -172,7 +172,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do
either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors localPackages Nothing targetStrings
- targets :: TargetsMap <-
+ targets <-
either (reportBuildTargetProblems verbosity) return $
resolveTargetsFromSolver
selectPackageTargets
@@ -196,7 +196,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do
reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems verbosity = reportTargetProblems verbosity "target"
-printTargetForms :: Verbosity -> [String] -> TargetsMap -> ElaboratedInstallPlan -> IO ()
+printTargetForms :: Verbosity -> [String] -> TargetsMapS -> ElaboratedInstallPlan -> IO ()
printTargetForms verbosity targetStrings targets elaboratedPlan =
noticeDoc verbosity $
vcat
@@ -222,7 +222,7 @@ printTargetForms verbosity targetStrings targets elaboratedPlan =
sort $
catMaybes
[ targetForm ct <$> pkg
- | (u :: UnitId, xs) <- Map.toAscList targets
+ | (WithStage _ u, xs) <- Map.toAscList targets
, let pkg = safeHead $ filter ((== u) . elabUnitId) localPkgs
, (ct :: ComponentTarget, _) <- xs
]
diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs
index 14b4b8a8d7d..563cea4c64d 100644
--- a/cabal-install/src/Distribution/Client/CmdTest.hs
+++ b/cabal-install/src/Distribution/Client/CmdTest.hs
@@ -67,6 +67,7 @@ import Distribution.Verbosity
import qualified System.Exit (exitSuccess)
import Distribution.Client.Errors
+import Distribution.Utils.LogProgress (runLogProgress)
import GHC.Environment
( getFullArgs
)
@@ -151,11 +152,13 @@ testAction flags@NixStyleFlags{..} targetStrings globalFlags = do
Nothing
targetSelectors
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionTest
- targets
- elaboratedPlan
+ elaboratedPlan' <-
+ runLogProgress verbosity $
+ pruneInstallPlanToTargets
+ TargetActionTest
+ targets
+ elaboratedPlan
+
return (elaboratedPlan', targets)
printPlan verbosity baseCtx buildCtx
diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
index aab09b38edf..3a54dd3fbe8 100644
--- a/cabal-install/src/Distribution/Client/Config.hs
+++ b/cabal-install/src/Distribution/Client/Config.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternSynonyms #-}
@@ -114,6 +113,7 @@ import Distribution.Utils.NubList
)
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as M
import Distribution.Client.Errors
import Distribution.Client.HttpUtils
@@ -208,6 +208,7 @@ import Distribution.Simple.Utils
, notice
, toUTF8BS
, warn
+ , writeFileAtomic
)
import Distribution.Solver.Types.ConstraintSource
import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath)
@@ -233,7 +234,6 @@ import System.Directory
import System.FilePath
( normalise
, takeDirectory
- , (<.>)
, ()
)
import System.IO.Error
@@ -578,6 +578,10 @@ instance Semigroup SavedConfig where
combineMonoid savedConfigureExFlags configAllowOlder
, configWriteGhcEnvironmentFilesPolicy =
combine configWriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor = combine configBuildHcFlavor
+ , configBuildHcPath = combine configBuildHcPath
+ , configBuildHcPkg = combine configBuildHcPkg
+ , configBuildPackageDBs = lastNonEmpty configBuildPackageDBs
}
where
combine = combine' savedConfigureExFlags
@@ -1046,7 +1050,7 @@ getConfigFilePathAndSource verbosity configFileFlag =
sources =
[ (CommandlineOption, return . flagToMaybe $ configFileFlag)
- , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)
+ , (EnvironmentVariable, lookup "CABAL_CONFIG" <$> getEnvironment)
, (Default, defaultSource)
]
@@ -1078,11 +1082,10 @@ createDefaultConfigFile verbosity extraLines filePath = do
writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
writeConfigFile file comments vals = do
- let tmpFile = file <.> "tmp"
createDirectoryIfMissing True (takeDirectory file)
- writeFile tmpFile $
- explanation ++ showConfigWithComments comments vals ++ "\n"
- renameFile tmpFile file
+ writeFileAtomic file $
+ LBS.fromStrict . toUTF8BS $
+ explanation ++ showConfigWithComments comments vals ++ "\n"
where
explanation =
unlines
diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs
index 5d1a1f9bc9f..5c77dff570e 100644
--- a/cabal-install/src/Distribution/Client/Configure.hs
+++ b/cabal-install/src/Distribution/Client/Configure.hs
@@ -42,7 +42,8 @@ import Distribution.Client.Setup
, filterConfigureFlags
)
import Distribution.Client.SetupWrapper
- ( SetupScriptOptions (..)
+ ( SetupRunnerArgs (NotInLibrary)
+ , SetupScriptOptions (..)
, defaultSetupScriptOptions
, setupWrapper
)
@@ -52,7 +53,7 @@ import Distribution.Client.Targets
, userToPackageConstraint
)
import Distribution.Client.Types as Source
-
+import Distribution.Client.Types.ReadyPackage (ReadyPackage)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
@@ -67,6 +68,7 @@ import Distribution.Solver.Types.PkgConfigDb
)
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage
+import qualified Distribution.Solver.Types.Stage as Stage
import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags)
import Distribution.Package
@@ -204,6 +206,7 @@ configure
configCommonFlags
(const (return configFlags))
(const extraArgs)
+ NotInLibrary
Right installPlan0 ->
let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
in case fst (InstallPlan.ready installPlan) of
@@ -247,7 +250,6 @@ configure
(flagToMaybe (configCabalVersion configExFlags))
)
Nothing
- False
logMsg message rest = debug verbosity message >> rest
@@ -259,7 +261,6 @@ configureSetupScript
-> SymbolicPath Pkg (Dir Dist)
-> VersionRange
-> Maybe Lock
- -> Bool
-> InstalledPackageIndex
-> Maybe ReadyPackage
-> SetupScriptOptions
@@ -271,7 +272,6 @@ configureSetupScript
distPref
cabalVersion
lock
- forceExternal
index
mpkg =
SetupScriptOptions
@@ -289,7 +289,6 @@ configureSetupScript
, useExtraEnvOverrides = []
, setupCacheLock = lock
, useWin32CleanHack = False
- , forceExternalSetupMethod = forceExternal
, -- If we have explicit setup dependencies, list them; otherwise, we give
-- the empty list of dependencies; ideally, we would fix the version of
-- Cabal here, so that we no longer need the special case for that in
@@ -465,14 +464,18 @@ planLocalPackage
. setSolveExecutables (SolveExecutables False)
. setSolverVerbosity (verbosityLevel verbosity)
$ standardInstallPolicy
- installedPkgIndex
-- NB: We pass in an *empty* source package database,
-- because cabal configure assumes that all dependencies
-- have already been installed
(SourcePackageDb mempty packagePrefs)
[SpecificSourcePackage localPkg]
- return (resolveDependencies platform (compilerInfo comp) pkgConfigDb resolverParams)
+ return $
+ resolveDependencies
+ (Stage.always (compilerInfo comp, platform))
+ (Stage.always pkgConfigDb)
+ (Stage.always installedPkgIndex)
+ resolverParams
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ReadyPackage'. In particular the
@@ -507,6 +510,7 @@ configurePackage
configCommonFlags
(return . configureFlags)
(const extraArgs)
+ NotInLibrary
where
gpkg :: PkgDesc.GenericPackageDescription
gpkg = srcpkgDescription spkg
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index 7656a67aba9..0af476a1534 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -1,7 +1,5 @@
-----------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
+{-# LANGUAGE LambdaCase #-}
-- |
-- Module : Distribution.Client.Dependency
-- Copyright : (c) David Himmelstrup 2005,
@@ -65,6 +63,7 @@ module Distribution.Client.Dependency
, addSetupCabalMinVersionConstraint
, addSetupCabalMaxVersionConstraint
, addSetupCabalProfiledDynamic
+ , setImplicitSetupInfo
) where
import Distribution.Client.Compat.Prelude
@@ -116,7 +115,8 @@ import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Simple.Setup
- ( asBool
+ ( BooleanFlag
+ , asBool
)
import Distribution.Solver.Modular
( PruneAfterFirstSuccess (..)
@@ -138,6 +138,8 @@ import Distribution.Types.DependencySatisfaction
)
import Distribution.Verbosity
( VerbosityLevel (..)
+ , deafening
+ , normal
)
import Distribution.Version
@@ -161,16 +163,20 @@ import Distribution.Solver.Types.SolverPackage
( SolverPackage (SolverPackage)
)
import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Toolchain
import Distribution.Solver.Types.Variable
import Control.Exception
( assert
)
+import Data.Foldable (fold)
import Data.List
( maximumBy
)
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
+import Text.PrettyPrint
-- ------------------------------------------------------------
@@ -186,7 +192,7 @@ data DepResolverParams = DepResolverParams
, depResolverConstraints :: [LabeledPackageConstraint]
, depResolverPreferences :: [PackagePreference]
, depResolverPreferenceDefault :: PackagesPreferenceDefault
- , depResolverInstalledPkgIndex :: InstalledPackageIndex
+ , depResolverInstalledPkgIndex :: InstalledPackageIndex -> InstalledPackageIndex
, depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage
, depResolverReorderGoals :: ReorderGoals
, depResolverCountConflicts :: CountConflicts
@@ -215,47 +221,48 @@ data DepResolverParams = DepResolverParams
showDepResolverParams :: DepResolverParams -> String
showDepResolverParams p =
- "targets: "
- ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))
- ++ "\nconstraints: "
- ++ concatMap
- (("\n " ++) . showLabeledConstraint)
- (depResolverConstraints p)
- ++ "\npreferences: "
- ++ concatMap
- (("\n " ++) . showPackagePreference)
- (depResolverPreferences p)
- ++ "\nstrategy: "
- ++ show (depResolverPreferenceDefault p)
- ++ "\nreorder goals: "
- ++ show (asBool (depResolverReorderGoals p))
- ++ "\ncount conflicts: "
- ++ show (asBool (depResolverCountConflicts p))
- ++ "\nfine grained conflicts: "
- ++ show (asBool (depResolverFineGrainedConflicts p))
- ++ "\nminimize conflict set: "
- ++ show (asBool (depResolverMinimizeConflictSet p))
- ++ "\nindependent goals: "
- ++ show (asBool (depResolverIndependentGoals p))
- ++ "\navoid reinstalls: "
- ++ show (asBool (depResolverAvoidReinstalls p))
- ++ "\nshadow packages: "
- ++ show (asBool (depResolverShadowPkgs p))
- ++ "\nstrong flags: "
- ++ show (asBool (depResolverStrongFlags p))
- ++ "\nallow boot library installs: "
- ++ show (asBool (depResolverAllowBootLibInstalls p))
- ++ "\nonly constrained packages: "
- ++ show (depResolverOnlyConstrained p)
- ++ "\nmax backjumps: "
- ++ maybe
- "infinite"
- show
- (depResolverMaxBackjumps p)
+ render $
+ vcat
+ [ hang (text "targets:") 2 $
+ vcat [text (prettyShow pkgname) | pkgname <- Set.toList (depResolverTargets p)]
+ , hang (text "constraints:") 2 $
+ vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p]
+ , hang (text "constraints:") 2 $
+ vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p]
+ , hang (text "preferences:") 2 $
+ if depResolverVerbosity p >= Deafening
+ then vcat [text (showPackagePreference pref) | pref <- depResolverPreferences p]
+ else text "... increase verbosity to see"
+ , hang (text "strategy:") 2 $
+ text (show (depResolverPreferenceDefault p))
+ , hang (text "reorder goals:") 2 $
+ prettyBool (depResolverReorderGoals p)
+ , hang (text "count conflicts:") 2 $
+ prettyBool (depResolverCountConflicts p)
+ , hang (text "fine grained conflicts:") 2 $
+ prettyBool (depResolverFineGrainedConflicts p)
+ , hang (text "minimize conflict set:") 2 $
+ prettyBool (depResolverMinimizeConflictSet p)
+ , hang (text "avoid reinstalls:") 2 $
+ prettyBool (depResolverAvoidReinstalls p)
+ , hang (text "shadow packages:") 2 $
+ prettyBool (depResolverShadowPkgs p)
+ , hang (text "strong flags:") 2 $
+ prettyBool (depResolverStrongFlags p)
+ , hang (text "allow boot library installs:") 2 $
+ prettyBool (depResolverAllowBootLibInstalls p)
+ , hang (text "only constrained packages:") 2 $
+ text (show (depResolverOnlyConstrained p))
+ , hang (text "max backjumps:") 2 $
+ text (maybe "infinite" show (depResolverMaxBackjumps p))
+ ]
where
- showLabeledConstraint :: LabeledPackageConstraint -> String
- showLabeledConstraint (LabeledPackageConstraint pc src) =
- showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
+ prettyBool :: BooleanFlag a => a -> Doc
+ prettyBool = pretty . asBool
+
+ prettyLabeledConstraint :: LabeledPackageConstraint -> Doc
+ prettyLabeledConstraint (LabeledPackageConstraint pc src) =
+ pretty pc <+> parens (pretty src)
-- | A package selection preference for a particular package.
--
@@ -282,16 +289,15 @@ showPackagePreference (PackageStanzasPreference pn st) =
prettyShow pn ++ " " ++ show st
basicDepResolverParams
- :: InstalledPackageIndex
- -> PackageIndex.PackageIndex UnresolvedSourcePackage
+ :: PackageIndex.PackageIndex UnresolvedSourcePackage
-> DepResolverParams
-basicDepResolverParams installedPkgIndex sourcePkgIndex =
+basicDepResolverParams sourcePkgIndex =
DepResolverParams
{ depResolverTargets = Set.empty
, depResolverConstraints = []
, depResolverPreferences = []
, depResolverPreferenceDefault = PreferLatestForSelected
- , depResolverInstalledPkgIndex = installedPkgIndex
+ , depResolverInstalledPkgIndex = id
, depResolverSourcePkgIndex = sourcePkgIndex
, depResolverReorderGoals = ReorderGoals False
, depResolverCountConflicts = CountConflicts True
@@ -448,7 +454,7 @@ dependOnWiredIns compiler params = addConstraints extraConstraints params
where
extraConstraints =
[ LabeledPackageConstraint
- (PackageConstraint (ScopeAnyQualifier pkgName) (PackagePropertyInstalledSpecificUnitId unitId))
+ (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgName)) (PackagePropertyInstalledSpecificUnitId unitId))
ConstraintSourceNonReinstallablePackage
| (pkgName, unitId) <- fromMaybe [] $ compilerInfoWiredInUnitIds compiler
]
@@ -461,7 +467,7 @@ dontInstallNonReinstallablePackages params =
where
extraConstraints =
[ LabeledPackageConstraint
- (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)
+ (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled)
ConstraintSourceNonReinstallablePackage
| pkgname <- nonReinstallablePackages
]
@@ -514,10 +520,8 @@ hideInstalledPackagesSpecificBySourcePackageId pkgids params =
-- TODO: this should work using exclude constraints instead
params
{ depResolverInstalledPkgIndex =
- foldl'
- (flip InstalledPackageIndex.deleteSourcePackageId)
- (depResolverInstalledPkgIndex params)
- pkgids
+ (\idx -> foldl' (flip InstalledPackageIndex.deleteSourcePackageId) idx pkgids)
+ . depResolverInstalledPkgIndex params
}
hideInstalledPackagesAllVersions
@@ -528,10 +532,8 @@ hideInstalledPackagesAllVersions pkgnames params =
-- TODO: this should work using exclude constraints instead
params
{ depResolverInstalledPkgIndex =
- foldl'
- (flip InstalledPackageIndex.deletePackageName)
- (depResolverInstalledPkgIndex params)
- pkgnames
+ (\idx -> foldl' (flip InstalledPackageIndex.deletePackageName) idx pkgnames)
+ . depResolverInstalledPkgIndex params
}
-- | Remove upper bounds in dependencies using the policy specified by the
@@ -614,49 +616,96 @@ removeBound RelaxUpper RelaxDepModNone = removeUpperBound
removeBound RelaxLower RelaxDepModCaret = transformCaretLower
removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper
--- | Supply defaults for packages without explicit Setup dependencies
+-- | Supply defaults for packages without explicit Setup dependencies.
+-- It also serves to add the implicit dependency on @hooks-exe@ needed to
+-- compile the @Setup.hs@ executable produced from 'SetupHooks' when
+-- @build-type: Hooks@. The first argument function determines which implicit
+-- dependencies are needed (including the one on @hooks-exe@).
--
-- Note: It's important to apply 'addDefaultSetupDepends' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
addDefaultSetupDependencies
- :: (UnresolvedSourcePackage -> Maybe [Dependency])
+ :: (Maybe [Dependency] -> PD.BuildType -> Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo)
+ -- ^ Function to update the SetupBuildInfo of the package using those dependencies
+ -> (UnresolvedSourcePackage -> Maybe [Dependency])
+ -- ^ Function to determine extra setup dependencies
-> DepResolverParams
-> DepResolverParams
-addDefaultSetupDependencies defaultSetupDeps params =
+addDefaultSetupDependencies applyDefaultSetupDeps defaultSetupDeps params =
params
{ depResolverSourcePkgIndex =
- fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
+ fmap go (depResolverSourcePkgIndex params)
}
where
- applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
- applyDefaultSetupDeps srcpkg =
+ go :: UnresolvedSourcePackage -> UnresolvedSourcePackage
+ go srcpkg =
srcpkg
{ srcpkgDescription =
gpkgdesc
{ PD.packageDescription =
pkgdesc
{ PD.setupBuildInfo =
- case PD.setupBuildInfo pkgdesc of
- Just sbi -> Just sbi
- Nothing -> case defaultSetupDeps srcpkg of
- Nothing -> Nothing
- Just deps
- | isCustom ->
- Just
- PD.SetupBuildInfo
- { PD.defaultSetupDepends = True
- , PD.setupDepends = deps
- }
- | otherwise -> Nothing
+ addCabalDepForHooks (PD.buildType pkgdesc) $
+ applyDefaultSetupDeps
+ (defaultSetupDeps srcpkg)
+ (PD.buildType pkgdesc)
+ (PD.setupBuildInfo pkgdesc)
}
}
}
where
- isCustom = PD.buildType pkgdesc == PD.Custom || PD.buildType pkgdesc == PD.Hooks
gpkgdesc = srcpkgDescription srcpkg
pkgdesc = PD.packageDescription gpkgdesc
+-- | Add an implicit dependency on @Cabal@ for a @build-type: Hooks@ package
+-- that doesn't explicitly depend on @Cabal@. Rationale: we need the @Cabal@
+-- library in order to compile @main = defaultMainWithSetupHooks setupHooks@.
+--
+-- This ensures the solver picks a consistent version of @Cabal@ when other
+-- packages in the @setup-depends@ stanza depend on @Cabal@.
+-- See https://github.com/haskell/cabal/issues/11331.
+--
+-- NB: don't do this for @build-type: Custom@, as it is possible for such
+-- packages to not depend on @Cabal@ at all (although basically unheard of
+-- in practice).
+addCabalDepForHooks :: PD.BuildType -> Maybe PD.SetupBuildInfo -> Maybe PD.SetupBuildInfo
+addCabalDepForHooks PD.Hooks = fmap addDep
+ where
+ addDep sbi@(PD.SetupBuildInfo{PD.setupDepends = deps})
+ | any ((== cabalPkgName) . depPkgName) deps =
+ sbi
+ | otherwise =
+ sbi{PD.setupDepends = Dependency cabalPkgName anyVersion mainLibSet : deps}
+ cabalPkgName = mkPackageName "Cabal"
+addCabalDepForHooks _ = id
+
+-- | Provides the fallback default "setup-depends", when:
+--
+-- 1. There is no 'SetupBuildInfo' to start with,
+-- 2. The passed-in optional default dependencies are not @Nothing@.
+setImplicitSetupInfo
+ :: Maybe [Dependency]
+ -- ^ optional default dependencies
+ -> PD.BuildType
+ -> Maybe PD.SetupBuildInfo
+ -> Maybe PD.SetupBuildInfo
+setImplicitSetupInfo mdeps buildty msetupinfo =
+ case msetupinfo of
+ Just sbi -> Just sbi
+ Nothing -> case mdeps of
+ Nothing -> Nothing
+ Just deps
+ | hasSetupStanza ->
+ Just
+ PD.SetupBuildInfo
+ { PD.defaultSetupDepends = True
+ , PD.setupDepends = deps
+ }
+ | otherwise -> Nothing
+ where
+ hasSetupStanza = buildty == PD.Custom || buildty == PD.Hooks
+
-- | If a package has a custom setup then we need to add a setup-depends
-- on Cabal.
addSetupCabalMinVersionConstraint
@@ -667,7 +716,7 @@ addSetupCabalMinVersionConstraint minVersion =
addConstraints
[ LabeledPackageConstraint
( PackageConstraint
- (ScopeAnySetupQualifier cabalPkgname)
+ (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
(PackagePropertyVersion $ orLaterVersion minVersion)
)
ConstraintSetupCabalMinVersion
@@ -685,7 +734,7 @@ addSetupCabalMaxVersionConstraint maxVersion =
addConstraints
[ LabeledPackageConstraint
( PackageConstraint
- (ScopeAnySetupQualifier cabalPkgname)
+ (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
(PackagePropertyVersion $ earlierVersion maxVersion)
)
ConstraintSetupCabalMaxVersion
@@ -701,7 +750,7 @@ addSetupCabalProfiledDynamic =
addConstraints
[ LabeledPackageConstraint
( PackageConstraint
- (ScopeAnySetupQualifier cabalPkgname)
+ (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
(PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0]))
)
ConstraintSourceProfiledDynamic
@@ -718,12 +767,10 @@ reinstallTargets params =
-- | A basic solver policy on which all others are built.
basicInstallPolicy
- :: InstalledPackageIndex
- -> SourcePackageDb
+ :: SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
basicInstallPolicy
- installedPkgIndex
(SourcePackageDb sourcePkgIndex sourcePkgPrefs)
pkgSpecifiers =
addPreferences
@@ -739,7 +786,6 @@ basicInstallPolicy
. addSourcePackages
[pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
$ basicDepResolverParams
- installedPkgIndex
sourcePkgIndex
-- | The policy used by all the standard commands, install, fetch, freeze etc
@@ -747,14 +793,12 @@ basicInstallPolicy
--
-- It extends the 'basicInstallPolicy' with a policy on setup deps.
standardInstallPolicy
- :: InstalledPackageIndex
- -> SourcePackageDb
+ :: SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
-standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers =
- addDefaultSetupDependencies mkDefaultSetupDeps $
+standardInstallPolicy sourcePkgDb pkgSpecifiers =
+ addDefaultSetupDependencies setImplicitSetupInfo mkDefaultSetupDeps $
basicInstallPolicy
- installedPkgIndex
sourcePkgDb
pkgSpecifiers
where
@@ -800,14 +844,14 @@ runSolver = modularResolver
-- a 'Progress' structure that can be unfolded to provide progress information,
-- logging messages and the final result or an error.
resolveDependencies
- :: Platform
- -> CompilerInfo
- -> Maybe PkgConfigDb
+ :: Staged (CompilerInfo, Platform)
+ -> Staged (Maybe PkgConfigDb)
+ -> Staged InstalledPackageIndex
-> DepResolverParams
-> Progress String String SolverInstallPlan
-resolveDependencies platform comp pkgConfigDB params =
+resolveDependencies toolchains pkgConfigDB installedPkgIndex params =
Step (showDepResolverParams finalparams) $
- fmap (validateSolverResult platform comp indGoals) $
+ fmap (validateSolverResult toolchains) $
formatProgress $
runSolver
( SolverConfig
@@ -827,11 +871,10 @@ resolveDependencies platform comp pkgConfigDB params =
verbosity
(PruneAfterFirstSuccess False)
)
- platform
- comp
- installedPkgIndex
- sourcePkgIndex
+ toolchains
pkgConfigDB
+ installedPkgIndex'
+ sourcePkgIndex
preferences
constraints
targets
@@ -841,7 +884,7 @@ resolveDependencies platform comp pkgConfigDB params =
constraints
prefs
defpref
- installedPkgIndex
+ installedPkgIndexM
sourcePkgIndex
reordGoals
cntConflicts
@@ -863,6 +906,12 @@ resolveDependencies platform comp pkgConfigDB params =
then dependOnWiredIns comp params
else dontInstallNonReinstallablePackages params
+ comp = fst (getStage toolchains Host)
+
+ installedPkgIndex' = Staged $ \case
+ Build -> getStage installedPkgIndex Build
+ Host -> installedPkgIndexM (getStage installedPkgIndex Host)
+
formatProgress :: Progress SummarizedMessage String a -> Progress String String a
formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p
@@ -931,14 +980,13 @@ interpretPackagesPreference selected defaultPref prefs =
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
validateSolverResult
- :: Platform
- -> CompilerInfo
- -> IndependentGoals
+ :: HasCallStack
+ => Staged (CompilerInfo, Platform)
-> [ResolverPackage UnresolvedPkgLoc]
-> SolverInstallPlan
-validateSolverResult platform comp indepGoals pkgs =
- case planPackagesProblems platform comp pkgs of
- [] -> case SolverInstallPlan.new indepGoals graph of
+validateSolverResult toolchains pkgs =
+ case planPackagesProblems toolchains pkgs of
+ [] -> case SolverInstallPlan.new (IndependentGoals False) graph of
Right plan -> plan
Left problems -> error (formatPlanProblems problems)
problems -> error (formatPkgProblems problems)
@@ -982,14 +1030,13 @@ showPlanPackageProblem (DuplicatePackageSolverId pid dups) =
++ " duplicate instances."
planPackagesProblems
- :: Platform
- -> CompilerInfo
+ :: Staged (CompilerInfo, Platform)
-> [ResolverPackage UnresolvedPkgLoc]
-> [PlanPackageProblem]
-planPackagesProblems platform cinfo pkgs =
+planPackagesProblems toolchains pkgs =
[ InvalidConfiguredPackage pkg packageProblems
| Configured pkg <- pkgs
- , let packageProblems = configuredPackageProblems platform cinfo pkg
+ , let packageProblems = configuredPackageProblems toolchains pkg
, not (null packageProblems)
]
++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups
@@ -1038,14 +1085,12 @@ showPackageProblem (InvalidDep dep pkgid) =
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
configuredPackageProblems
- :: Platform
- -> CompilerInfo
+ :: Staged (CompilerInfo, Platform)
-> SolverPackage UnresolvedPkgLoc
-> [PackageProblem]
configuredPackageProblems
- platform
- cinfo
- (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
+ toolchains
+ (SolverPackage stage _qpn pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
[ DuplicateFlag flag
| flag <- PD.findDuplicateFlagAssignments specifiedFlags
]
@@ -1072,9 +1117,6 @@ configuredPackageProblems
specifiedDeps1 :: ComponentDeps [PackageId]
specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0
- specifiedDeps :: [PackageId]
- specifiedDeps = CD.flatDeps specifiedDeps1
-
mergedFlags :: [MergeResult PD.FlagName PD.FlagName]
mergedFlags =
mergeBy
@@ -1091,7 +1133,7 @@ configuredPackageProblems
dependencyName (Dependency name _ _) = name
mergedDeps :: [MergeResult Dependency PackageId]
- mergedDeps = mergeDeps requiredDeps specifiedDeps
+ mergedDeps = mergeDeps requiredDeps (fold specifiedDeps1)
mergeDeps
:: [Dependency]
@@ -1118,8 +1160,8 @@ configuredPackageProblems
specifiedFlags
compSpec
(const Satisfied)
- platform
- cinfo
+ (snd (getStage toolchains stage))
+ (fst (getStage toolchains stage))
[]
(srcpkgDescription pkg) of
Right (resolvedPkg, _) ->
@@ -1158,6 +1200,7 @@ configuredPackageProblems
-- It simply means preferences for installed packages will be ignored.
resolveWithoutDependencies
:: DepResolverParams
+ -> InstalledPackageIndex
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies
( DepResolverParams
@@ -1165,7 +1208,7 @@ resolveWithoutDependencies
constraints
prefs
defpref
- installedPkgIndex
+ installedPkgIndexM
sourcePkgIndex
_reorderGoals
_countConflicts
@@ -1182,7 +1225,8 @@ resolveWithoutDependencies
_onlyConstrained
_order
_verbosity
- ) =
+ )
+ installedPkgIndex =
collectEithers $ map selectPackage (Set.toList targets)
where
selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
@@ -1207,6 +1251,7 @@ resolveWithoutDependencies
bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
bestByPrefs = comparing $ \pkg ->
(installPref pkg, versionPref pkg, packageVersion pkg)
+
installPref :: UnresolvedSourcePackage -> Bool
installPref = case preferInstalled of
Preference.PreferLatest -> const False
@@ -1215,8 +1260,9 @@ resolveWithoutDependencies
not
. null
. InstalledPackageIndex.lookupSourcePackageId
- installedPkgIndex
+ (installedPkgIndexM installedPkgIndex)
. packageId
+
versionPref :: Package a => a -> Int
versionPref pkg =
length . filter (packageVersion pkg `withinRange`) $
diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs
index 0a6e51b09e7..8067c12ecb1 100644
--- a/cabal-install/src/Distribution/Client/DistDirLayout.hs
+++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs
@@ -34,6 +34,7 @@ import Distribution.Client.Config
( defaultLogsDir
, defaultStoreDir
)
+import Distribution.Client.Toolchain (Stage)
import Distribution.Compiler
import Distribution.Package
( ComponentId
@@ -51,7 +52,6 @@ import Distribution.Simple.Compiler
import Distribution.Simple.Configure (interpretPackageDbFlags)
import Distribution.System
import Distribution.Types.ComponentName
-import Distribution.Types.LibraryName
-- | Information which can be used to construct the path to
-- the build directory of a build. This is LESS fine-grained
@@ -59,7 +59,8 @@ import Distribution.Types.LibraryName
-- and for good reason: we don't want this path to change if
-- the user, say, adds a dependency to their project.
data DistDirParams = DistDirParams
- { distParamUnitId :: UnitId
+ { distParamStage :: Stage
+ , distParamUnitId :: UnitId
, distParamPackageId :: PackageId
, distParamComponentId :: ComponentId
, distParamComponentName :: Maybe ComponentName
@@ -199,28 +200,10 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir =
distBuildDirectory :: DistDirParams -> FilePath
distBuildDirectory params =
distBuildRootDirectory
+ prettyShow (distParamStage params)
prettyShow (distParamPlatform params)
prettyShow (distParamCompilerId params)
- prettyShow (distParamPackageId params)
- ( case distParamComponentName params of
- Nothing -> ""
- Just (CLibName LMainLibName) -> ""
- Just (CLibName (LSubLibName name)) -> "l" prettyShow name
- Just (CFLibName name) -> "f" prettyShow name
- Just (CExeName name) -> "x" prettyShow name
- Just (CTestName name) -> "t" prettyShow name
- Just (CBenchName name) -> "b" prettyShow name
- )
- ( case distParamOptimization params of
- NoOptimisation -> "noopt"
- NormalOptimisation -> ""
- MaximumOptimisation -> "opt"
- )
- ( let uid_str = prettyShow (distParamUnitId params)
- in if uid_str == prettyShow (distParamComponentId params)
- then ""
- else uid_str
- )
+ prettyShow (distParamUnitId params)
distUnpackedSrcRootDirectory :: FilePath
distUnpackedSrcRootDirectory = distDirectory "src"
diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs
index 033edd8e619..a5497c0bab4 100644
--- a/cabal-install/src/Distribution/Client/Errors.hs
+++ b/cabal-install/src/Distribution/Client/Errors.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
@@ -24,6 +23,7 @@ import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BS8
import Data.List (groupBy)
import Distribution.Client.IndexUtils.Timestamp
+import Distribution.Client.ProjectPlanning.Stage (WithStage)
import qualified Distribution.Client.Types.Repo as Repo
import qualified Distribution.Client.Types.RepoName as RepoName
import Distribution.Compat.Prelude
@@ -96,7 +96,7 @@ data CabalInstallException
| PlanPackages String
| NoSupportForRunCommand
| RunPhaseReached
- | UnknownExecutable String UnitId
+ | UnknownExecutable String (WithStage UnitId)
| MultipleMatchingExecutables String [String]
| CmdRunReportTargetProblems String
| CleanAction [String]
@@ -713,21 +713,18 @@ exceptionMessageCabalInstall e = case e of
]
]
| (target, nosuch) <- targets
- , let groupByContainer =
- map
- ( \g@((inside, _, _, _) : _) ->
- ( inside
- , [ (thing, got, alts)
- | (_, thing, got, alts) <- g
- ]
- )
- )
- . groupBy ((==) `on` (\(x, _, _, _) -> x))
- . sortBy (compare `on` (\(x, _, _, _) -> x))
]
where
mungeThing "file" = "file target"
mungeThing thing = thing
+ groupByContainer xs =
+ [ ( inside
+ , [ (thing, got, alts)
+ | (_, thing, got, alts) <- g
+ ]
+ )
+ | g@((inside, _, _, _) : _) <- groupBy ((==) `on` (\(x, _, _, _) -> x)) $ sortBy (compare `on` (\(x, _, _, _) -> x)) xs
+ ]
TargetSelectorAmbiguousErr targets ->
unlines
[ "Ambiguous target '"
diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs
index 13c6f23415e..2f4ab5f5cff 100644
--- a/cabal-install/src/Distribution/Client/Fetch.hs
+++ b/cabal-install/src/Distribution/Client/Fetch.hs
@@ -38,6 +38,7 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb)
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
+import qualified Distribution.Solver.Types.Stage as Stage
import Distribution.Client.Errors
import Distribution.Package
@@ -175,9 +176,9 @@ planPackages
installPlan <-
foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $
resolveDependencies
- platform
- (compilerInfo comp)
- pkgConfigDb
+ (Stage.always (compilerInfo comp, platform))
+ (Stage.always pkgConfigDb)
+ (Stage.always installedPkgIndex)
resolverParams
-- The packages we want to fetch are those packages the 'InstallPlan'
@@ -189,7 +190,7 @@ planPackages
]
| otherwise =
either (dieWithException verbosity . PlanPackages . unlines . map show) return $
- resolveWithoutDependencies resolverParams
+ resolveWithoutDependencies resolverParams installedPkgIndex
where
resolverParams :: DepResolverParams
resolverParams =
@@ -221,7 +222,7 @@ planPackages
-- already installed. Since we want to get the source packages of
-- things we might have installed (but not have the sources for).
. reinstallTargets
- $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+ $ standardInstallPolicy sourcePkgDb pkgSpecifiers
includeDependencies = fromFlag (fetchDeps fetchFlags)
logMsg message rest = debug verbosity message >> rest
diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs
index dd2ac14791d..e4fca6481a8 100644
--- a/cabal-install/src/Distribution/Client/FileMonitor.hs
+++ b/cabal-install/src/Distribution/Client/FileMonitor.hs
@@ -127,17 +127,47 @@ data MonitorStateGlob
!MonitorStateGlobRel
deriving (Show, Generic)
+-- | Monitoring state for a 'Glob'. Constructors mirror those of Glob
data MonitorStateGlobRel
- = MonitorStateGlobDirs
+ = -- | Monitoring state for 'GlobDir'
+ MonitorStateGlobDirs
!GlobPieces
+ -- ^ Glob matching on subdirectory in current directory
!Glob
+ -- ^ Glob tail matching on anything below subdirectory
!ModTime
- ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted
- | MonitorStateGlobFiles
+ -- ^ Cached directory modification time
+ ![(FilePath, MonitorStateGlobRel)]
+ -- ^ Per-file monitoring state.
+ -- Invariant: sorted
+ | -- | Monitoring state for 'GlobFile'
+ MonitorStateGlobFiles
!GlobPieces
+ -- ^ Glob matching on file in current directory
!ModTime
+ -- ^ Cached directory modification time
![(FilePath, MonitorStateFileStatus)] -- invariant: sorted
- | MonitorStateGlobDirTrailing
+
+ -- ^ Per-file monitoring state.
+ -- Invariant: sorted
+ | -- | Monitoring state for 'GlobDirRecursive'
+ MonitorStateGlobRecursive
+ !GlobPieces
+ -- ^ Glob matching on file in current directory subtree (current
+ -- directory and all of its descendants).
+ !ModTime
+ -- ^ Cached directory modification time
+ ![(FilePath, MonitorStateFileStatus)]
+ -- ^ Per-file monitoring state for files immediately below the current
+ -- directory.
+ -- Invariant: sorted
+ ![(FilePath, MonitorStateGlobRel)]
+ -- ^ Monitoring state for immediate subdirectories. Transient
+ -- subdirectories are represented recursively within these.
+ -- Invariant: sorted
+ | -- | Monitoring state for 'GlobDirTrailing'
+ -- (Trivial, because there is no data in 'GlobDirTrailing')
+ MonitorStateGlobDirTrailing
deriving (Show, Generic)
instance Binary MonitorStateGlob
@@ -161,10 +191,18 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =
MonitorFileGlob kindfile kinddir $
RootedGlob root $
- case gstate of
- MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
- MonitorStateGlobFiles glob _ _ -> GlobFile glob
- MonitorStateGlobDirTrailing -> GlobDirTrailing
+ monitorStateGlobRelGlob gstate
+
+-- | Reconstruct a 'Glob' from a 'MonitorStateGlobRel'. This simply erases the
+-- additional information in 'MonitorStateGlobRel' added via
+-- 'buildMonitorStateGlobRel'.
+monitorStateGlobRelGlob :: MonitorStateGlobRel -> Glob
+monitorStateGlobRelGlob gstate =
+ case gstate of
+ MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
+ MonitorStateGlobFiles glob _ _ -> GlobFile glob
+ MonitorStateGlobRecursive glob _ _ _ -> GlobDirRecursive glob
+ MonitorStateGlobDirTrailing -> GlobDirTrailing
------------------------------------------------------------------------------
-- Checking the status of monitored files
@@ -522,7 +560,60 @@ probeMonitorStateGlob
MonitorStateGlob kindfile kinddir globroot
<$> probeMonitorStateGlobRel kindfile kinddir root "" glob
-probeMonitorStateGlobRel
+probeMonitorStateFiles
+ :: FilePath
+ -- ^ root path
+ -> FilePath
+ -- ^ path of the directory we are
+ -- looking in relative to @root@
+ -> GlobPieces
+ -- ^ file glob to filter monitored files
+ -> ModTime
+ -- ^ cached directory modification time
+ -> [(FilePath, MonitorStateFileStatus)]
+ -> ChangedM (ModTime, [(FilePath, MonitorStateFileStatus)])
+probeMonitorStateFiles
+ root
+ dirName
+ glob
+ mtime
+ children = do
+ change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime
+ mtime' <- case change of
+ Nothing -> return mtime
+ Just mtime' -> do
+ -- directory modification time changed:
+ -- a matching file may have been added or deleted
+ matches <-
+ return . filter (matchGlobPieces glob)
+ =<< liftIO (listDirectory (root dirName))
+
+ traverse_ probeMergeResult $
+ mergeBy
+ (\(path1, _) path2 -> compare path1 path2)
+ children
+ (sort matches)
+ return mtime'
+
+ -- Check that none of the children have changed
+ for_ children $ \(file, status) ->
+ probeMonitorStateFileStatus root (dirName file) status
+
+ return (mtime', children)
+ where
+ -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use
+ -- the new mtime' if any.
+
+ probeMergeResult
+ :: MergeResult (FilePath, MonitorStateFileStatus) FilePath
+ -> ChangedM ()
+ probeMergeResult mr = case mr of
+ InBoth _ _ -> return ()
+ -- this is just to be able to accurately report which file changed:
+ OnlyInLeft (path, _) -> somethingChanged (dirName path)
+ OnlyInRight path -> somethingChanged (dirName path)
+
+probeMonitorStateDirs
:: MonitorKindFile
-> MonitorKindDir
-> FilePath
@@ -530,14 +621,23 @@ probeMonitorStateGlobRel
-> FilePath
-- ^ path of the directory we are
-- looking in relative to @root@
- -> MonitorStateGlobRel
- -> ChangedM MonitorStateGlobRel
-probeMonitorStateGlobRel
+ -> Maybe GlobPieces
+ -- ^ optional glob to filter filenames by
+ -> Glob
+ -- ^ glob to filter subdirectories by
+ -> ModTime
+ -- ^ cached directory modification time
+ -> [(FilePath, MonitorStateGlobRel)]
+ -> ChangedM (ModTime, [(FilePath, MonitorStateGlobRel)])
+probeMonitorStateDirs
kindfile
kinddir
root
dirName
- (MonitorStateGlobDirs glob globPath mtime children) = do
+ globMaybe
+ globPath
+ mtime
+ children = do
change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime
case change of
Nothing -> do
@@ -554,7 +654,7 @@ probeMonitorStateGlobRel
return (fname, fstate')
| (fname, fstate) <- children
]
- return $! MonitorStateGlobDirs glob globPath mtime children'
+ return $! (mtime, children')
Just mtime' -> do
-- directory modification time changed:
-- a matching subdir may have been added or deleted
@@ -564,7 +664,7 @@ probeMonitorStateGlobRel
let subdir = root dirName entry
in liftIO $ doesDirectoryExist subdir
)
- . filter (matchGlobPieces glob)
+ . maybe id (filter . matchGlobPieces) globMaybe
=<< liftIO (listDirectory (root dirName))
children' <-
@@ -573,7 +673,7 @@ probeMonitorStateGlobRel
(\(path1, _) path2 -> compare path1 path2)
children
(sort matches)
- return $! MonitorStateGlobDirs glob globPath mtime' children'
+ return $! (mtime', children')
where
-- Note that just because the directory has changed, we don't force
-- a cache rewrite with 'cacheChanged' since that has some cost, and
@@ -626,17 +726,56 @@ probeMonitorStateGlobRel
fstate
return (path, fstate')
- -- \| Does a 'MonitorStateGlob' have any relevant files within it?
- allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]
- allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =
+ allMatchingFilesFromGlobFiles :: FilePath -> [(FilePath, a)] -> [FilePath]
+ allMatchingFilesFromGlobFiles dir entries =
[dir fname | (fname, _) <- entries]
- allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =
+
+ allMatchingFilesFromGlobDirs :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [FilePath]
+ allMatchingFilesFromGlobDirs dir entries =
[ res
| (subdir, fstate) <- entries
, res <- allMatchingFiles (dir subdir) fstate
]
+
+ -- \| Does a 'MonitorStateGlob' have any relevant files within it?
+ allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]
+ allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =
+ allMatchingFilesFromGlobFiles dir entries
+ allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =
+ allMatchingFilesFromGlobDirs dir entries
+ allMatchingFiles dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) =
+ allMatchingFilesFromGlobFiles dir fileEntries
+ ++ allMatchingFilesFromGlobDirs dir dirEntries
allMatchingFiles dir MonitorStateGlobDirTrailing =
[dir]
+
+probeMonitorStateGlobRel
+ :: MonitorKindFile
+ -> MonitorKindDir
+ -> FilePath
+ -- ^ root path
+ -> FilePath
+ -- ^ path of the directory we are
+ -- looking in relative to @root@
+ -> MonitorStateGlobRel
+ -> ChangedM MonitorStateGlobRel
+probeMonitorStateGlobRel
+ kindfile
+ kinddir
+ root
+ dirName
+ (MonitorStateGlobDirs glob globPath mtime children) = do
+ (mtime', children') <-
+ probeMonitorStateDirs
+ kindfile
+ kinddir
+ root
+ dirName
+ (Just glob)
+ globPath
+ mtime
+ children
+ return $! MonitorStateGlobDirs glob globPath mtime' children'
probeMonitorStateGlobRel
_
_
@@ -677,6 +816,33 @@ probeMonitorStateGlobRel
-- this is just to be able to accurately report which file changed:
OnlyInLeft (path, _) -> somethingChanged (dirName path)
OnlyInRight path -> somethingChanged (dirName path)
+probeMonitorStateGlobRel
+ kindfile
+ kinddir
+ root
+ dirName
+ (MonitorStateGlobRecursive glob mtime fileChildren dirChildren) = do
+ -- For recursive globs, we check the file children first, then recurse
+ -- into subdirectories, applying the same logic as 'MonitorStateGlobFiles'
+ -- and 'MonitorStateGlobDirs', respectively.
+ (_, fileChildren') <-
+ probeMonitorStateFiles
+ root
+ dirName
+ glob
+ mtime
+ fileChildren
+ (mtime', dirChildren') <-
+ probeMonitorStateDirs
+ kindfile
+ kinddir
+ root
+ dirName
+ Nothing
+ (GlobDirRecursive glob)
+ mtime
+ dirChildren
+ return $! MonitorStateGlobRecursive glob mtime' fileChildren' dirChildren'
probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =
return MonitorStateGlobDirTrailing
@@ -916,7 +1082,37 @@ buildMonitorStateGlobRel
dirEntries <- listDirectory absdir
dirMTime <- getModTime absdir
case globPath of
- GlobDirRecursive{} -> error "Monitoring directory-recursive globs (i.e. ../**/...) is currently unsupported"
+ GlobDirRecursive glob -> do
+ -- evaluate globPath' over the current directory
+ let files = filter (matchGlobPieces glob) dirEntries
+ filesStates <-
+ for (sort files) $ \file -> do
+ fstate <-
+ buildMonitorStateFile
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ (dir file)
+ return (file, fstate)
+ -- evaluate globPath' over every subdirectory
+ subdirs <-
+ filterM (\subdir -> doesDirectoryExist (absdir subdir)) dirEntries
+ subdirStates <-
+ for (sort subdirs) $ \subdir -> do
+ fstate <-
+ buildMonitorStateGlobRel
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ (dir subdir)
+ globPath
+ return (subdir, fstate)
+
+ return $! MonitorStateGlobRecursive glob dirMTime filesStates subdirStates
GlobDir glob globPath' -> do
subdirs <-
filterM (\subdir -> doesDirectoryExist (absdir subdir)) $
@@ -1015,16 +1211,27 @@ readCacheFileHashes monitor =
, (fpath, (mtime, hash)) <- collectGlobHashes "" gstate
]
- collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))]
- collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
+ collectDirHashes :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [(FilePath, (ModTime, HashValue))]
+ collectDirHashes dir entries =
[ res
| (subdir, fstate) <- entries
, res <- collectGlobHashes (dir subdir) fstate
]
- collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =
+
+ collectFileHashes :: FilePath -> [(FilePath, MonitorStateFileStatus)] -> [(FilePath, (ModTime, HashValue))]
+ collectFileHashes dir entries =
[ (dir fname, (mtime, hash))
| (fname, MonitorStateFileHashed mtime hash) <- entries
]
+
+ collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))]
+ collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
+ collectDirHashes dir entries
+ collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =
+ collectFileHashes dir entries
+ collectGlobHashes dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) =
+ collectFileHashes dir fileEntries
+ ++ collectDirHashes dir dirEntries
collectGlobHashes _dir MonitorStateGlobDirTrailing =
[]
diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs
index a586b72d66d..7052515e8ce 100644
--- a/cabal-install/src/Distribution/Client/Freeze.hs
+++ b/cabal-install/src/Distribution/Client/Freeze.hs
@@ -51,7 +51,10 @@ import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb
+import Distribution.Solver.Types.ResolverPackage (solverId)
import Distribution.Solver.Types.SolverId
+import Distribution.Solver.Types.SolverPackage (SolverPackage (..))
+import qualified Distribution.Solver.Types.Stage as Stage
import Distribution.Client.Errors
import Distribution.Package
@@ -184,7 +187,7 @@ getFreezePkgs
where
sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck pkgSpecifiers = do
- when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
+ unless (null [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
dieWithException verbosity UnexpectedNamedPkgSpecifiers
when (length pkgSpecifiers /= 1) $
dieWithException verbosity UnexpectedSourcePkgSpecifiers
@@ -213,9 +216,9 @@ planPackages
installPlan <-
foldProgress logMsg (dieWithException verbosity . FreezeException) return $
resolveDependencies
- platform
- (compilerInfo comp)
- pkgConfigDb
+ (Stage.always (compilerInfo comp, platform))
+ (Stage.always pkgConfigDb)
+ (Stage.always installedPkgIndex)
resolverParams
return $ pruneInstallPlan installPlan pkgSpecifiers
@@ -246,7 +249,7 @@ planPackages
in LabeledPackageConstraint pc ConstraintSourceFreeze
| pkgSpecifier <- pkgSpecifiers
]
- $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+ $ standardInstallPolicy sourcePkgDb pkgSpecifiers
logMsg message rest = debug verbosity message >> rest
@@ -287,9 +290,15 @@ pruneInstallPlan installPlan pkgSpecifiers =
removeSelf pkgIds $
SolverInstallPlan.dependencyClosure installPlan pkgIds
where
+ -- Get the source packages from the (specific) package specifiers.
+ srcpkgs :: [UnresolvedSourcePackage]
+ srcpkgs = [pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
+ -- Get the 'SolverId's of the packages we are freezing.
+ pkgIds :: [SolverId]
pkgIds =
- [ PlannedId (packageId pkg)
- | SpecificSourcePackage pkg <- pkgSpecifiers
+ [ solverId (SolverInstallPlan.Configured pkg)
+ | SolverInstallPlan.Configured pkg <- SolverInstallPlan.toList installPlan
+ , solverPkgSource pkg `elem` srcpkgs
]
removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
removeSelf _ =
diff --git a/cabal-install/src/Distribution/Client/GZipUtils.hs b/cabal-install/src/Distribution/Client/GZipUtils.hs
index 995419b881d..8946ddd946a 100644
--- a/cabal-install/src/Distribution/Client/GZipUtils.hs
+++ b/cabal-install/src/Distribution/Client/GZipUtils.hs
@@ -42,7 +42,7 @@ maybeDecompress bytes = runST (go bytes decompressor)
-- (https://en.wikipedia.org/wiki/Gzip#File_structure)
-- at the beginning of the gzip header. (not an option for zlib, though.)
go :: Monad m => ByteString -> DecompressStream m -> m ByteString
- go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k
+ go cs (DecompressOutputAvailable bs k) = Chunk bs <$> (go' cs =<< k)
go _ (DecompressStreamEnd _bs) = return Empty
go _ (DecompressStreamError _err) = return bytes
go cs (DecompressInputRequired k) = go cs' =<< k c
@@ -53,7 +53,7 @@ maybeDecompress bytes = runST (go bytes decompressor)
-- and we throw them (as pure exceptions).
-- TODO: We could (and should) avoid these pure exceptions.
go' :: Monad m => ByteString -> DecompressStream m -> m ByteString
- go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k
+ go' cs (DecompressOutputAvailable bs k) = Chunk bs <$> (go' cs =<< k)
go' _ (DecompressStreamEnd _bs) = return Empty
go' _ (DecompressStreamError err) = throw err
go' cs (DecompressInputRequired k) = go' cs' =<< k c
diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs
index 44de794c878..2df320aef77 100644
--- a/cabal-install/src/Distribution/Client/Get.hs
+++ b/cabal-install/src/Distribution/Client/Get.hs
@@ -125,6 +125,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
either (dieWithException verbosity . PkgSpecifierException . map show) return $
resolveWithoutDependencies
(resolverParams sourcePkgDb pkgSpecifiers)
+ mempty
unless (null prefix) $
createDirectoryIfMissing True prefix
@@ -143,7 +144,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
resolverParams sourcePkgDb pkgSpecifiers =
-- TODO: add command-line constraint and preference args for unpack
- standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
+ standardInstallPolicy sourcePkgDb pkgSpecifiers
onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags)
diff --git a/cabal-install/src/Distribution/Client/InLibrary.hs b/cabal-install/src/Distribution/Client/InLibrary.hs
new file mode 100644
index 00000000000..847222a14cd
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/InLibrary.hs
@@ -0,0 +1,341 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Distribution.Client.InLibrary
+ ( libraryConfigureInputsFromElabPackage
+ , configure
+ , build
+ , haddock
+ , copy
+ , register
+ , repl
+ , test
+ , bench
+ )
+where
+
+import Distribution.Backpack.DescribeUnitId (setupMessage')
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Client.RebuildMonad
+import qualified Distribution.Client.SetupHooks.CallHooksExe as ExternalHooksExe
+ ( buildTypePreBuildHooks
+ , buildTypeSetupHooks
+ )
+import Distribution.Client.Types
+
+import qualified Distribution.PackageDescription as PD
+import Distribution.Simple (Compiler, PackageDBStackCWD)
+import qualified Distribution.Simple.Bench as Cabal
+import Distribution.Simple.Build (build_setupHooks, repl_setupHooks)
+import qualified Distribution.Simple.Configure as Cabal
+import Distribution.Simple.Haddock (haddock_setupHooks)
+import Distribution.Simple.Install (install_setupHooks)
+import Distribution.Simple.LocalBuildInfo (mbWorkDirLBI)
+import qualified Distribution.Simple.PreProcess as Cabal
+import Distribution.Simple.Program.Db
+import qualified Distribution.Simple.Register as Cabal
+import qualified Distribution.Simple.Setup as Cabal
+import Distribution.Simple.SetupHooks.Internal
+import qualified Distribution.Simple.Test as Cabal
+import Distribution.Simple.Utils
+import Distribution.Client.Toolchain (Toolchain (..))
+import Distribution.Solver.Types.Stage (Stage (..))
+import Distribution.Solver.Types.Stage (getStage)
+import Distribution.System (Platform)
+import Distribution.Types.BuildType
+import Distribution.Types.ComponentRequestedSpec
+import qualified Distribution.Types.LocalBuildConfig as LBC
+import Distribution.Types.LocalBuildInfo
+import Distribution.Utils.Path
+ ( makeSymbolicPath
+ , relativeSymbolicPath
+ )
+import Distribution.Verbosity
+ ( VerbosityHandles
+ , mkVerbosity
+ )
+
+import Distribution.Types.HookedBuildInfo (emptyHookedBuildInfo)
+import System.Directory (canonicalizePath)
+
+--------------------------------------------------------------------------------
+-- Configure
+
+data LibraryConfigureInputs = LibraryConfigureInputs
+ { verbosityHandles :: VerbosityHandles
+ , compiler :: Compiler
+ , platform :: Platform
+ , buildType :: BuildType
+ , compRequested :: Maybe PD.ComponentName
+ , localBuildConfig :: LBC.LocalBuildConfig
+ , packageDBStack :: PackageDBStackCWD
+ , packageDescription :: PD.PackageDescription
+ , gPackageDescription :: PD.GenericPackageDescription
+ , flagAssignment :: PD.FlagAssignment
+ }
+
+libraryConfigureInputsFromElabPackage
+ :: VerbosityHandles
+ -> BuildType
+ -> ProgramDb
+ -> ElaboratedSharedConfig
+ -> ElaboratedReadyPackage
+ -> [String]
+ -- ^ targets
+ -> LibraryConfigureInputs
+libraryConfigureInputsFromElabPackage
+ verbHandles
+ bt
+ progDb
+ -- NB: don't use the ProgramDb from the ElaboratedSharedConfig;
+ -- that one is only for the compiler itself and not for the package.
+ ElaboratedSharedConfig
+ { pkgConfigToolchains = toolchains
+ }
+ (ReadyPackage pkg)
+ userTargets =
+ LibraryConfigureInputs
+ { verbosityHandles = verbHandles
+ , compiler = compil
+ , platform = plat
+ , buildType =
+ -- NB: don't get the build-type from 'pkgDescr',
+ -- because for Configure build-type we rewrite the build-type
+ -- to Simple for components that are neither the main library
+ -- nor an executable.
+ --
+ -- See also 'isMainLibOrExeComponent'.
+ bt
+ , compRequested =
+ case elabPkgOrComp pkg of
+ ElabComponent elabComp
+ | Just elabCompNm <- compComponentName elabComp ->
+ Just elabCompNm
+ _ -> Nothing
+ , localBuildConfig =
+ LBC.LocalBuildConfig
+ { LBC.extraConfigArgs = userTargets
+ , LBC.withPrograms = progDb
+ , LBC.withBuildOptions = elabBuildOptions pkg
+ }
+ , packageDBStack = elabBuildPackageDBStack pkg
+ , packageDescription = pkgDescr
+ , gPackageDescription = gpkgDescr
+ , flagAssignment = elabFlagAssignment pkg
+ }
+ where
+ pkgDescr = elabPkgDescription pkg
+ gpkgDescr = elabGPkgDescription pkg
+ hostToolchain = getStage toolchains Host
+ plat = toolchainPlatform hostToolchain
+ compil = toolchainCompiler hostToolchain
+
+configure
+ :: LibraryConfigureInputs
+ -> Cabal.ConfigFlags
+ -> IO LocalBuildInfo
+configure
+ LibraryConfigureInputs
+ { verbosityHandles = verbHandles
+ , platform = plat
+ , compiler = compil
+ , buildType = bt
+ , compRequested = mbComp
+ , localBuildConfig = lbc0
+ , packageDBStack = packageDBs
+ , packageDescription = pkgDescr
+ , gPackageDescription = gpkgDescr
+ , flagAssignment = flagAssgn
+ }
+ cfg = do
+ -- Here, we essentially want to call the Cabal library 'configure' function,
+ -- but skipping over all the steps we don't need such as rediscovering the
+ -- compiler or re-resolving the conditionals in the package, as we have done
+ -- all of that already.
+ --
+ -- To achieve this, we call the Cabal 'configureFinal' function which skips
+ -- these preparatory steps.
+ let verbFlags = Cabal.fromFlag $ Cabal.configVerbosity cfg
+ verbosity = mkVerbosity verbHandles verbFlags
+ mbWorkDir = Cabal.flagToMaybe $ Cabal.configWorkingDir cfg
+ distPref = Cabal.fromFlag $ Cabal.configDistPref cfg
+ confHooks =
+ configureHooks $
+ ExternalHooksExe.buildTypeSetupHooks verbosity mbWorkDir distPref bt
+
+ -- cabal-install uses paths relative to the current working directory,
+ -- while the Cabal library expects symbolic paths. Perform the conversion here
+ -- by making the paths absolute.
+ packageDBs' <- traverse (traverse $ fmap makeSymbolicPath . canonicalizePath) packageDBs
+
+ -- Configure package
+ let pkgId :: PD.PackageIdentifier
+ pkgId = PD.package pkgDescr
+ case mbComp of
+ Nothing -> setupMessage verbosity "Configuring" pkgId
+ Just cname ->
+ setupMessage'
+ verbosity
+ "Configuring"
+ pkgId
+ cname
+ (Just (Cabal.configInstantiateWith cfg))
+
+ -- TODO: we should implement recompilation checking on the level of
+ -- individual components, so that we only re-configure the components that
+ -- need reconfiguring (including running their hooks). See #11761.
+ lbc1 <- case preConfPackageHook confHooks of
+ Nothing -> return lbc0
+ Just hk -> Cabal.runPreConfPackageHook cfg compil plat lbc0 hk
+ let compRequestedSpec = case mbComp of
+ Just compName -> OneComponentRequestedSpec compName
+ Nothing ->
+ ComponentRequestedSpec
+ { testsRequested = Cabal.fromFlag (Cabal.configTests cfg)
+ , benchmarksRequested = Cabal.fromFlag (Cabal.configBenchmarks cfg)
+ }
+ (_allConstraints, pkgInfo) <-
+ Cabal.computePackageInfo verbHandles cfg lbc1 gpkgDescr compil
+ -- It's OK to discard constraints here: we already have a finalized PackageDescription
+ -- in hand, and we are using exact UnitIds for all dependencies (this corresponds
+ -- to using --exact-configuration and --dependency flags with the Setup CLI).
+
+ -- Post-configure hooks & per-component configure
+ lbi1 <-
+ Cabal.configureFinal
+ verbHandles
+ confHooks
+ emptyHookedBuildInfo
+ cfg
+ lbc1
+ (gpkgDescr, pkgDescr)
+ flagAssgn
+ compRequestedSpec
+ compil
+ plat
+ packageDBs'
+ pkgInfo
+
+ -- Remember the .cabal filename if we know it.
+ pkgDescrFilePath <-
+ case Cabal.flagToMaybe $ Cabal.configCabalFilePath cfg of
+ Just pkgFile -> return pkgFile
+ Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir
+ return $ lbi1{pkgDescrFile = Just pkgDescrFilePath}
+
+--------------------------------------------------------------------------------
+-- Build
+
+build
+ :: VerbosityHandles
+ -> Cabal.BuildFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO [MonitorFilePath]
+build verbHandles flags lbi _args =
+ build_setupHooks (preBuildHook, postBuildHook) verbHandles pkgDescr lbi flags Cabal.knownSuffixHandlers
+ where
+ verb = mkVerbosity verbHandles $ Cabal.fromFlag $ Cabal.buildVerbosity flags
+ hooks = ExternalHooksExe.buildTypeSetupHooks verb mbWorkDir distPref bt
+ -- (Recall that pre-build hooks are treated specially;
+ -- see the 'buildTypeSetupHooks' and 'buildTypePreBuildHooks' functions.)
+ preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt
+ postBuildHook
+ | Just postBuild <- postBuildComponentHook $ buildHooks hooks =
+ postBuild
+ | otherwise =
+ const $ return ()
+ pkgDescr = localPkgDescr lbi
+ bt = PD.buildType pkgDescr
+ mbWorkDir = mbWorkDirLBI lbi
+ distPref = Cabal.fromFlag $ Cabal.buildDistPref flags
+
+--------------------------------------------------------------------------------
+-- Haddock
+
+haddock
+ :: VerbosityHandles
+ -> Cabal.HaddockFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO [MonitorFilePath]
+haddock verbHandles flags lbi _args =
+ haddock_setupHooks preBuildHook verbHandles pkgDescr lbi Cabal.knownSuffixHandlers flags
+ where
+ preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt
+ pkgDescr = localPkgDescr lbi
+ bt = PD.buildType pkgDescr
+ mbWorkDir = mbWorkDirLBI lbi
+ distPref = Cabal.fromFlag $ Cabal.haddockDistPref flags
+
+--------------------------------------------------------------------------------
+-- Repl
+
+repl
+ :: VerbosityHandles
+ -> Cabal.ReplFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO [MonitorFilePath]
+repl verbHandles flags lbi _args =
+ repl_setupHooks preBuildHook verbHandles pkgDescr lbi flags Cabal.knownSuffixHandlers []
+ where
+ preBuildHook = ExternalHooksExe.buildTypePreBuildHooks verbHandles mbWorkDir distPref bt
+ pkgDescr = localPkgDescr lbi
+ bt = PD.buildType pkgDescr
+ mbWorkDir = mbWorkDirLBI lbi
+ distPref = Cabal.fromFlag $ Cabal.replDistPref flags
+
+--------------------------------------------------------------------------------
+-- Copy
+
+copy
+ :: VerbosityHandles
+ -> Cabal.CopyFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO ()
+copy verbHandles flags lbi _args =
+ install_setupHooks hooks verbHandles pkgDescr lbi flags
+ where
+ verb = mkVerbosity verbHandles $ Cabal.fromFlag $ Cabal.copyVerbosity flags
+ hooks = installHooks $ ExternalHooksExe.buildTypeSetupHooks verb mbWorkDir distPref bt
+ pkgDescr = localPkgDescr lbi
+ bt = PD.buildType pkgDescr
+ mbWorkDir = mbWorkDirLBI lbi
+ distPref = Cabal.fromFlag $ Cabal.copyDistPref flags
+
+--------------------------------------------------------------------------------
+-- Test, bench, register.
+--
+-- NB: no hooks into these phases.
+
+test
+ :: VerbosityHandles
+ -> Cabal.TestFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO ()
+test verb flags lbi args =
+ Cabal.test args verb pkgDescr lbi flags
+ where
+ pkgDescr = localPkgDescr lbi
+
+bench
+ :: VerbosityHandles
+ -> Cabal.BenchmarkFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO ()
+bench verb flags lbi args =
+ Cabal.bench args verb pkgDescr lbi flags
+ where
+ pkgDescr = localPkgDescr lbi
+
+register
+ :: Cabal.RegisterFlags
+ -> LocalBuildInfo
+ -> [String]
+ -> IO ()
+register flags lbi _args = Cabal.register pkgDescr lbi flags
+ where
+ pkgDescr = localPkgDescr lbi
diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs
index 8872ad6467f..e842fa131f3 100644
--- a/cabal-install/src/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/src/Distribution/Client/IndexUtils.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
@@ -29,6 +28,7 @@ module Distribution.Client.IndexUtils
, getSourcePackagesAtIndexState
, ActiveRepos
, filterSkippedActiveRepos
+ , applyStrategy
, Index (..)
, RepoIndexState (..)
, PackageEntry (..)
@@ -372,16 +372,8 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
ts /= NoTimestamp
]
- let addIndex
- :: PackageIndex UnresolvedSourcePackage
- -> (RepoData, CombineStrategy)
- -> PackageIndex UnresolvedSourcePackage
- addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc
- addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx
- addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx
-
let pkgs :: PackageIndex UnresolvedSourcePackage
- pkgs = foldl' addIndex mempty pkgss'
+ pkgs = foldl' (\acc (rd, s) -> applyStrategy acc (rdIndex rd, s)) mempty pkgss'
-- Note: preferences combined without using CombineStrategy
let prefs :: Map PackageName VersionRange
@@ -413,6 +405,19 @@ data RepoData = RepoData
, rdPreferences :: [Dependency]
}
+-- | Fold one package index into an accumulator according to a 'CombineStrategy'.
+--
+-- This is the per-repository step used by 'getSourcePackagesAtIndexState' when
+-- building the combined 'PackageIndex' from multiple repositories.
+applyStrategy
+ :: Package pkg
+ => PackageIndex pkg
+ -> (PackageIndex pkg, CombineStrategy)
+ -> PackageIndex pkg
+applyStrategy acc (_, CombineStrategySkip) = acc
+applyStrategy acc (idx, CombineStrategyMerge) = PackageIndex.merge acc idx
+applyStrategy acc (idx, CombineStrategyOverride) = PackageIndex.override acc idx
+
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
diff --git a/cabal-install/src/Distribution/Client/Init.hs b/cabal-install/src/Distribution/Client/Init.hs
index f9cd589f2a9..0c0d8d95a98 100644
--- a/cabal-install/src/Distribution/Client/Init.hs
+++ b/cabal-install/src/Distribution/Client/Init.hs
@@ -55,5 +55,5 @@ initCmd v packageDBs repoCtxt comp progdb initFlags = do
| fromFlagOrDefault False (simpleProject initFlags) =
Simple.createProject
| otherwise = case interactive initFlags of
- Flag False -> NonInteractive.createProject comp
+ Flag False -> NonInteractive.createProject
_ -> Interactive.createProject
diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs
index f3d40806462..7543d3ecf83 100644
--- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs
+++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs
@@ -64,19 +64,17 @@ import Language.Haskell.Extension (Extension (..), Language (..))
import qualified Data.Set as Set
import Distribution.FieldGrammar.Newtypes
-import Distribution.Simple.Compiler
import System.FilePath (splitDirectories, ())
-- | Main driver for interactive prompt code.
createProject
:: Interactive m
- => Compiler
- -> Verbosity
+ => Verbosity
-> InstalledPackageIndex
-> SourcePackageDb
-> InitFlags
-> m ProjectSettings
-createProject comp v pkgIx srcDb initFlags = do
+createProject v pkgIx srcDb initFlags = do
-- The workflow is as follows:
--
-- 1. Get the package type, supplied as either a program input or
@@ -120,10 +118,10 @@ createProject comp v pkgIx srcDb initFlags = do
case pkgType of
Library -> do
- libTarget <- genLibTarget initFlags comp pkgIx cabalSpec
+ libTarget <- genLibTarget initFlags pkgIx cabalSpec
testTarget <-
addLibDepToTest pkgName
- <$> genTestTarget initFlags comp pkgIx cabalSpec
+ <$> genTestTarget initFlags pkgIx cabalSpec
return $
ProjectSettings
@@ -133,7 +131,7 @@ createProject comp v pkgIx srcDb initFlags = do
Nothing
testTarget
Executable -> do
- exeTarget <- genExeTarget initFlags comp pkgIx cabalSpec
+ exeTarget <- genExeTarget initFlags pkgIx cabalSpec
return $
ProjectSettings
@@ -143,13 +141,13 @@ createProject comp v pkgIx srcDb initFlags = do
(Just exeTarget)
Nothing
LibraryAndExecutable -> do
- libTarget <- genLibTarget initFlags comp pkgIx cabalSpec
+ libTarget <- genLibTarget initFlags pkgIx cabalSpec
exeTarget <-
addLibDepToExe pkgName
- <$> genExeTarget initFlags comp pkgIx cabalSpec
+ <$> genExeTarget initFlags pkgIx cabalSpec
testTarget <-
addLibDepToTest pkgName
- <$> genTestTarget initFlags comp pkgIx cabalSpec
+ <$> genTestTarget initFlags pkgIx cabalSpec
return $
ProjectSettings
@@ -159,7 +157,7 @@ createProject comp v pkgIx srcDb initFlags = do
(Just exeTarget)
testTarget
TestSuite -> do
- testTarget <- genTestTarget initFlags comp pkgIx cabalSpec
+ testTarget <- genTestTarget initFlags pkgIx cabalSpec
return $
ProjectSettings
@@ -191,15 +189,14 @@ genPkgDescription flags srcDb =
genLibTarget
:: Interactive m
=> InitFlags
- -> Compiler
-> InstalledPackageIndex
-> CabalSpecVersion
-> m LibTarget
-genLibTarget flags comp pkgs v = do
+genLibTarget flags pkgs v = do
srcDirs <- srcDirsHeuristics flags
let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs
LibTarget srcDirs
- <$> languageHeuristics flags comp
+ <$> languageHeuristics flags
<*> exposedModulesHeuristics flags
<*> libOtherModulesHeuristics flags
<*> otherExtsHeuristics flags srcDir
@@ -209,17 +206,16 @@ genLibTarget flags comp pkgs v = do
genExeTarget
:: Interactive m
=> InitFlags
- -> Compiler
-> InstalledPackageIndex
-> CabalSpecVersion
-> m ExeTarget
-genExeTarget flags comp pkgs v = do
+genExeTarget flags pkgs v = do
appDirs <- appDirsHeuristics flags
let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs
ExeTarget
<$> mainFileHeuristics flags
<*> pure appDirs
- <*> languageHeuristics flags comp
+ <*> languageHeuristics flags
<*> exeOtherModulesHeuristics flags
<*> otherExtsHeuristics flags appDir
<*> dependenciesHeuristics flags appDir pkgs
@@ -228,11 +224,10 @@ genExeTarget flags comp pkgs v = do
genTestTarget
:: Interactive m
=> InitFlags
- -> Compiler
-> InstalledPackageIndex
-> CabalSpecVersion
-> m (Maybe TestTarget)
-genTestTarget flags comp pkgs v = do
+genTestTarget flags pkgs v = do
initialized <- initializeTestSuiteHeuristics flags
testDirs' <- testDirsHeuristics flags
let testDir = fromMaybe defaultTestDir $ safeHead testDirs'
@@ -243,7 +238,7 @@ genTestTarget flags comp pkgs v = do
TestTarget
<$> testMainHeuristics flags
<*> pure testDirs'
- <*> languageHeuristics flags comp
+ <*> languageHeuristics flags
<*> testOtherModulesHeuristics flags
<*> otherExtsHeuristics flags testDir
<*> dependenciesHeuristics flags testDir pkgs
@@ -362,8 +357,8 @@ testDirsHeuristics :: Interactive m => InitFlags -> m [String]
testDirsHeuristics flags = getTestDirs flags $ return [defaultTestDir]
-- | Ask for the Haskell base language of the package.
-languageHeuristics :: Interactive m => InitFlags -> Compiler -> m Language
-languageHeuristics flags comp = getLanguage flags $ guessLanguage comp
+languageHeuristics :: Interactive m => InitFlags -> m Language
+languageHeuristics flags = getLanguage flags $ return defaultLanguage
-- | Ask whether to generate explanatory comments.
noCommentsHeuristics :: Interactive m => InitFlags -> m Bool
diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
index 923dd289dc0..a6cdffe5c58 100644
--- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
+++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
@@ -22,7 +22,6 @@ module Distribution.Client.Init.NonInteractive.Heuristics
, guessAuthorName
, guessAuthorEmail
, guessCabalSpecVersion
- , guessLanguage
, guessPackageType
, guessSourceDirectories
, guessApplicationDirectories
@@ -40,10 +39,8 @@ import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)
import Distribution.Client.Init.Types
import Distribution.Client.Init.Utils
import Distribution.FieldGrammar.Newtypes
-import Distribution.Simple.Compiler
import Distribution.Types.PackageName (PackageName)
import Distribution.Version
-import Language.Haskell.Extension
import System.FilePath
-- | Guess the main file, returns a default value if none is found.
@@ -71,15 +68,6 @@ guessCabalSpecVersion = do
_ -> Just defaultCabalVersion
Nothing -> pure defaultCabalVersion
--- | Guess the language specification based on the GHC version
-guessLanguage :: Interactive m => Compiler -> m Language
-guessLanguage Compiler{compilerId = CompilerId GHC ver} =
- return $
- if ver < mkVersion [7, 0, 1]
- then Haskell98
- else Haskell2010
-guessLanguage _ = return defaultLanguage
-
-- | Guess the package name based on the given root directory.
guessPackageName :: Interactive m => FilePath -> m PackageName
guessPackageName = filePathToPkgName
diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs
index 71d32ecb310..760e0b5f0fa 100644
--- a/cabal-install/src/Distribution/Client/Init/Types.hs
+++ b/cabal-install/src/Distribution/Client/Init/Types.hs
@@ -81,6 +81,7 @@ import Distribution.Fields.Pretty
import Distribution.ModuleName
import qualified Distribution.Package as P
import Distribution.Simple.Setup (Flag)
+import qualified Distribution.Simple.Utils as P
import Distribution.Verbosity (VerbosityFlags, VerbosityLevel (..), verbosityLevel)
import Distribution.Version
import Language.Haskell.Extension (Extension, Language (..))
@@ -403,7 +404,7 @@ instance Interactive PromptIO where
createDirectory = liftIO <$> P.createDirectory
removeDirectory = liftIO <$> P.removePathForcibly
writeFile a b = liftIO $ P.writeFile a b
- removeExistingFile = liftIO <$> P.removeExistingFile
+ removeExistingFile = liftIO <$> P.removeFileForcibly
copyFile a b = liftIO $ P.copyFile a b
renameDirectory a b = liftIO $ P.renameDirectory a b
hFlush = liftIO <$> System.IO.hFlush
diff --git a/cabal-install/src/Distribution/Client/Init/Utils.hs b/cabal-install/src/Distribution/Client/Init/Utils.hs
index bdb9b325666..0ac2221a2f0 100644
--- a/cabal-install/src/Distribution/Client/Init/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Init/Utils.hs
@@ -176,7 +176,7 @@ retrieveModuleImports m = do
-- | Given a module, retrieve all of its language pragmas
retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension]
retrieveModuleExtensions m = do
- catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m
+ mapMaybe (simpleParsec . trim) . grabModuleExtensions <$> readFile m
where
stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#')
diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs
index 93ee1baa405..b98df15d15b 100644
--- a/cabal-install/src/Distribution/Client/Install.hs
+++ b/cabal-install/src/Distribution/Client/Install.hs
@@ -51,7 +51,6 @@ import System.Directory
, doesFileExist
, getTemporaryDirectory
, listDirectory
- , removeFile
, renameDirectory
)
import System.FilePath
@@ -117,7 +116,8 @@ import Distribution.Client.Setup
, filterTestFlags
)
import Distribution.Client.SetupWrapper
- ( SetupScriptOptions (..)
+ ( SetupRunnerArgs (NotInLibrary)
+ , SetupScriptOptions (..)
, defaultSetupScriptOptions
, setupWrapper
)
@@ -127,6 +127,7 @@ import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Targets
import Distribution.Client.Types as Source
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
+import Distribution.Client.Types.ReadyPackage (ReadyPackage)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Solver.Types.PackageFixedDeps
@@ -142,6 +143,7 @@ import Distribution.Solver.Types.PkgConfigDb
)
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage as SourcePackage
+import qualified Distribution.Solver.Types.Stage as Stage
import Distribution.Client.ProjectConfig
import Distribution.Client.Utils
@@ -237,6 +239,7 @@ import Distribution.Simple.Utils as Utils
, dieWithException
, info
, notice
+ , removeFileForcibly
, warn
, withTempDirectory
)
@@ -274,6 +277,7 @@ import Distribution.Version
)
import qualified Data.ByteString as BS
+import Data.Foldable (fold)
import Distribution.Client.Errors
-- TODO:
@@ -336,7 +340,7 @@ install
++ "see https://github.com/haskell/cabal/issues/3353"
++ " (if you didn't type --root-cmd, comment out root-cmd"
++ " in your ~/.config/cabal/config file)"
- let userOrSandbox = fromFlag (configUserInstall configFlags)
+ let userOrSandbox = fromFlagOrDefault defaultUserInstall (configUserInstall configFlags)
unless userOrSandbox $
warn verbosity $
"the --global flag is deprecated -- "
@@ -582,9 +586,9 @@ planPackages
pkgConfigDb
pkgSpecifiers =
resolveDependencies
- platform
- (compilerInfo comp)
- pkgConfigDb
+ (Stage.always (compilerInfo comp, platform))
+ (Stage.always pkgConfigDb)
+ (Stage.always installedPkgIndex)
resolverParams
>>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
where
@@ -647,7 +651,6 @@ planPackages
-- doesn't understand how to install them
. setSolveExecutables (SolveExecutables False)
$ standardInstallPolicy
- installedPkgIndex
sourcePkgDb
pkgSpecifiers
@@ -713,7 +716,7 @@ pruneInstallPlan pkgSpecifiers =
nub
[ depid
| SolverInstallPlan.PackageMissingDeps _ depids <- problems
- , depid <- depids
+ , depid <- toList depids
, packageName depid `elem` targetnames
]
@@ -1002,7 +1005,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
)
)
_ <-
- CD.flatDeps (confPkgDeps cpkg)
+ fold (confPkgDeps cpkg)
]
revDeps :: Map.Map PackageId [PackageId]
@@ -1198,8 +1201,8 @@ storeDetailedBuildReports verbosity logsDir reports =
createDirectoryIfMissing True reportsDir -- FIXME
writeFile reportFile (show (showBuildReport report, buildLog))
| (report, Just repo) <- reports
- , Just remoteRepo <- [maybeRepoRemote repo]
, isLikelyToHaveLogFile (BuildReports.installOutcome report)
+ , Just remoteRepo <- [maybeRepoRemote repo]
]
where
isLikelyToHaveLogFile BuildReports.ConfigureFailed{} = True
@@ -1240,7 +1243,7 @@ regenerateHaddockIndex
defaultDirs <-
InstallDirs.defaultInstallDirs
(compilerFlavor comp)
- (fromFlag (configUserInstall configFlags))
+ (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))
True
let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate
@@ -1494,7 +1497,6 @@ performInstallations
distPref
(chooseCabalVersion configExFlags (libVersion miscOptions))
(Just lock)
- parallelInstall
index
(Just rpkg)
@@ -1959,7 +1961,7 @@ installUnpackedPackage
_ -> ipkgs
let packageDBs =
interpretPackageDbFlags
- (fromFlag (configUserInstall configFlags))
+ (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))
(configPackageDBs configFlags)
for_ ipkgs' $ \ipkg' ->
registerPackage
@@ -2061,13 +2063,12 @@ installUnpackedPackage
let logFileName = mkLogFileName (packageId pkg) uid
logDir = takeDirectory logFileName
unless (null logDir) $ createDirectoryIfMissing True logDir
- logFileExists <- doesFileExist logFileName
- when logFileExists $ removeFile logFileName
+ removeFileForcibly logFileName
return (Just logFileName)
setup cmd getCommonFlags flags mLogPath =
Exception.bracket
- (traverse (\path -> openFile path AppendMode) mLogPath)
+ (traverse (`openFile` AppendMode) mLogPath)
(traverse_ hClose)
( \logFileHandle ->
setupWrapper
@@ -2081,6 +2082,7 @@ installUnpackedPackage
getCommonFlags
flags
(const [])
+ NotInLibrary
)
-- helper
@@ -2115,7 +2117,7 @@ withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do
defaultDirs <-
InstallDirs.defaultInstallDirs
compFlavor
- (fromFlag (configUserInstall configFlags))
+ (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))
(PackageDescription.hasLibs pkg)
Win32SelfUpgrade.possibleSelfUpgrade
diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs
index bb427f44a2c..0ff295c4608 100644
--- a/cabal-install/src/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/src/Distribution/Client/InstallPlan.hs
@@ -1,7 +1,10 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -25,10 +28,11 @@ module Distribution.Client.InstallPlan
, PlanPackage
, GenericPlanPackage (..)
, foldPlanPackage
- , IsUnit
+ , renderPlanPackageTag
-- * Operations on 'InstallPlan's
, new
+ , new'
, toGraph
, toList
, toMap
@@ -41,6 +45,7 @@ module Distribution.Client.InstallPlan
, configureInstallPlan
, remove
, installed
+ , installedM
, lookup
, directDeps
, revDirectDeps
@@ -59,16 +64,19 @@ module Distribution.Client.InstallPlan
, failed
-- * Display
- , showPlanGraph
+ , renderPlanGraph
, ShowPlanNode (..)
, showInstallPlan
, showInstallPlan_gen
- , showPlanPackageTag
+ , PlanProblem
+ , renderPlanProblem
+ , renderPlanProblems
-- * Graph-like operations
, dependencyClosure
, reverseTopologicalOrder
, reverseDependencyClosure
+ , IsGraph (..)
) where
import Distribution.Client.Compat.Prelude hiding (lookup, toList)
@@ -90,9 +98,7 @@ import Distribution.Package
( HasMungedPackageId (..)
, HasUnitId (..)
, Package (..)
- , UnitId
)
-import Distribution.Pretty (defaultStyle)
import Distribution.Solver.Types.SolverPackage
import Text.PrettyPrint
@@ -110,11 +116,16 @@ import Distribution.Utils.Structured (Structure (Nominal), Structured (..))
import Control.Exception
( assert
)
+import Data.Bifoldable
+import Data.Bifunctor
+import Data.Bitraversable
import qualified Data.Foldable as Foldable (all, toList)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Compat.Graph (Graph, IsNode (..))
import qualified Distribution.Compat.Graph as Graph
+import GHC.Stack
-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
@@ -173,38 +184,33 @@ data GenericPlanPackage ipkg srcpkg
= PreExisting ipkg
| Configured srcpkg
| Installed srcpkg
- deriving (Eq, Show, Generic)
+ deriving (Eq, Show, Generic, Traversable, Foldable, Functor)
-displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String
-displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)
-displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)
-displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg)
+instance Bifunctor GenericPlanPackage where
+ bimap f _ (PreExisting ipkg) = PreExisting (f ipkg)
+ bimap _ g (Configured srcpkg) = Configured (g srcpkg)
+ bimap _ g (Installed srcpkg) = Installed (g srcpkg)
--- | Convenience combinator for destructing 'GenericPlanPackage'.
--- This is handy because if you case manually, you have to handle
--- 'Configured' and 'Installed' separately (where often you want
--- them to be the same.)
-foldPlanPackage
- :: (ipkg -> a)
- -> (srcpkg -> a)
- -> GenericPlanPackage ipkg srcpkg
- -> a
-foldPlanPackage f _ (PreExisting ipkg) = f ipkg
-foldPlanPackage _ g (Configured srcpkg) = g srcpkg
-foldPlanPackage _ g (Installed srcpkg) = g srcpkg
+instance Bifoldable GenericPlanPackage where
+ bifoldMap f _ (PreExisting ipkg) = f ipkg
+ bifoldMap _ g (Configured srcpkg) = g srcpkg
+ bifoldMap _ g (Installed srcpkg) = g srcpkg
-type IsUnit a = (IsNode a, Key a ~ UnitId)
+instance Bitraversable GenericPlanPackage where
+ bitraverse f _ (PreExisting ipkg) = PreExisting <$> f ipkg
+ bitraverse _ g (Configured srcpkg) = Configured <$> g srcpkg
+ bitraverse _ g (Installed srcpkg) = Installed <$> g srcpkg
-depends :: IsUnit a => a -> [UnitId]
-depends = nodeNeighbors
+-- I admit this is a bit awkward but I could not find a better way.
--- NB: Expanded constraint synonym here to avoid undecidable
--- instance errors in GHC 7.8 and earlier.
-instance
- (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
- => IsNode (GenericPlanPackage ipkg srcpkg)
- where
- type Key (GenericPlanPackage ipkg srcpkg) = UnitId
+class (IsNode a, IsNode b, Key a ~ Key b) => IsGraph a b where
+ type GraphKey a b
+
+instance (IsNode a, Key a ~ key, IsNode b, Key b ~ key) => IsGraph a b where
+ type GraphKey a b = Key a
+
+instance IsGraph ipkg srcpkg => IsNode (GenericPlanPackage ipkg srcpkg) where
+ type Key (GenericPlanPackage ipkg srcpkg) = GraphKey ipkg srcpkg
nodeKey (PreExisting ipkg) = nodeKey ipkg
nodeKey (Configured spkg) = nodeKey spkg
nodeKey (Installed spkg) = nodeKey spkg
@@ -215,11 +221,6 @@ instance
instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)
instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg)
-type PlanPackage =
- GenericPlanPackage
- InstalledPackageInfo
- (ConfiguredPackage UnresolvedPkgLoc)
-
instance
(Package ipkg, Package srcpkg)
=> Package (GenericPlanPackage ipkg srcpkg)
@@ -253,32 +254,45 @@ instance
configuredId (Configured spkg) = configuredId spkg
configuredId (Installed spkg) = configuredId spkg
-data GenericInstallPlan ipkg srcpkg = GenericInstallPlan
+displayGenericPlanPackage :: (IsNode ipkg, Key ipkg ~ key, IsNode srcpkg, Key srcpkg ~ key, Pretty key) => GenericPlanPackage ipkg srcpkg -> String
+displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)
+displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)
+displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg)
+
+-- | Convenience combinator for destructing 'GenericPlanPackage'.
+-- This is handy because if you case manually, you have to handle
+-- 'Configured' and 'Installed' separately (where often you want
+-- them to be the same.)
+foldPlanPackage
+ :: (ipkg -> a)
+ -> (srcpkg -> a)
+ -> GenericPlanPackage ipkg srcpkg
+ -> a
+foldPlanPackage f _ (PreExisting ipkg) = f ipkg
+foldPlanPackage _ g (Configured srcpkg) = g srcpkg
+foldPlanPackage _ g (Installed srcpkg) = g srcpkg
+
+depends :: IsNode a => a -> [Key a]
+depends = nodeNeighbors
+
+type PlanPackage =
+ GenericPlanPackage
+ InstalledPackageInfo
+ (ConfiguredPackage UnresolvedPkgLoc)
+
+data GenericInstallPlan' key ipkg srcpkg = GenericInstallPlan
{ planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg))
, planIndepGoals :: !IndependentGoals
}
+type GenericInstallPlan ipkg srcpkg = GenericInstallPlan' (GraphKey ipkg srcpkg) ipkg srcpkg
+
-- | 'GenericInstallPlan' specialised to most commonly used types.
type InstallPlan =
GenericInstallPlan
InstalledPackageInfo
(ConfiguredPackage UnresolvedPkgLoc)
--- | Smart constructor that deals with caching the 'Graph' representation.
-mkInstallPlan
- :: (IsUnit ipkg, IsUnit srcpkg)
- => String
- -> Graph (GenericPlanPackage ipkg srcpkg)
- -> IndependentGoals
- -> GenericInstallPlan ipkg srcpkg
-mkInstallPlan loc graph indepGoals =
- assert
- (valid loc graph)
- GenericInstallPlan
- { planGraph = graph
- , planIndepGoals = indepGoals
- }
-
internalError :: WithCallStack (String -> String -> a)
internalError loc msg =
error $
@@ -286,7 +300,10 @@ internalError loc msg =
++ loc
++ if null msg then "" else ": " ++ msg
-instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where
+instance
+ (Typeable key, Structured ipkg, Structured srcpkg)
+ => Structured (GenericInstallPlan' key ipkg srcpkg)
+ where
structure p =
Nominal
(typeRep p)
@@ -297,14 +314,14 @@ instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan
]
instance
- ( IsNode ipkg
- , Key ipkg ~ UnitId
- , IsNode srcpkg
- , Key srcpkg ~ UnitId
+ ( IsGraph ipkg srcpkg
+ , key ~ GraphKey ipkg srcpkg
, Binary ipkg
, Binary srcpkg
+ , Pretty key
+ , Show key
)
- => Binary (GenericInstallPlan ipkg srcpkg)
+ => Binary (GenericInstallPlan' key ipkg srcpkg)
where
put
GenericInstallPlan
@@ -313,23 +330,24 @@ instance
} = put graph >> put indepGoals
get = do
- graph <- get
- indepGoals <- get
- return $! mkInstallPlan "(instance Binary)" graph indepGoals
+ graph <- mkInstallPlan <$> get
+ return $! either (const (error "Deserialised invalid GenericInstallPlan")) id graph
data ShowPlanNode = ShowPlanNode
{ showPlanHerald :: Doc
, showPlanNeighbours :: [Doc]
}
-showPlanGraph :: [ShowPlanNode] -> String
-showPlanGraph graph =
- renderStyle defaultStyle $
- vcat (map dispPlanPackage graph)
+renderPlanGraph :: [ShowPlanNode] -> Doc
+renderPlanGraph graph =
+ vcat (map dispPlanPackage graph)
where
dispPlanPackage (ShowPlanNode herald neighbours) =
hang herald 2 (vcat neighbours)
+showPlanGraph :: [ShowPlanNode] -> String
+showPlanGraph = render . renderPlanGraph
+
-- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information
showInstallPlan_gen
:: forall ipkg srcpkg
@@ -340,7 +358,11 @@ showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . pla
showInstallPlan
:: forall ipkg srcpkg
- . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg)
+ . ( IsGraph ipkg srcpkg
+ , Package ipkg
+ , Package srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ )
=> GenericInstallPlan ipkg srcpkg
-> String
showInstallPlan = showInstallPlan_gen toShow
@@ -349,25 +371,59 @@ showInstallPlan = showInstallPlan_gen toShow
toShow p =
ShowPlanNode
( hsep
- [ text (showPlanPackageTag p)
+ [ renderPlanPackageTag p
, pretty (packageId p)
, parens (pretty (nodeKey p))
]
)
(map pretty (nodeNeighbors p))
-showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
-showPlanPackageTag (PreExisting _) = "PreExisting"
-showPlanPackageTag (Configured _) = "Configured"
-showPlanPackageTag (Installed _) = "Installed"
+renderPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> Doc
+renderPlanPackageTag (PreExisting _) = text "pre-existing"
+renderPlanPackageTag (Configured _) = text "configured"
+renderPlanPackageTag (Installed _) = text "installed"
--- | Build an installation plan from a valid set of resolved packages.
+-- | Smart constructor that deals with caching the 'Graph' representation.
+mkInstallPlan
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ )
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> Either Doc (GenericInstallPlan ipkg srcpkg)
+mkInstallPlan graph =
+ case NE.nonEmpty (problems graph) of
+ Just problems' -> Left $ renderPlanProblems (NE.toList problems')
+ Nothing -> Right $ GenericInstallPlan{planGraph = graph, planIndepGoals = IndependentGoals False}
+
+mkInstallPlan'
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ )
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan ipkg srcpkg)
+mkInstallPlan' graph =
+ case NE.nonEmpty (problems graph) of
+ Just problems' -> Left problems'
+ Nothing -> Right $ GenericInstallPlan{planGraph = graph, planIndepGoals = IndependentGoals False}
+
+-- | Build an installation plan from a set of packages.
new
- :: (IsUnit ipkg, IsUnit srcpkg)
- => IndependentGoals
- -> Graph (GenericPlanPackage ipkg srcpkg)
- -> GenericInstallPlan ipkg srcpkg
-new indepGoals graph = mkInstallPlan "new" graph indepGoals
+ :: ( IsGraph ipkg srcpkg
+ , Show (GraphKey ipkg srcpkg)
+ , Pretty (GraphKey ipkg srcpkg)
+ )
+ => [GenericPlanPackage ipkg srcpkg]
+ -> LogProgress (GenericInstallPlan ipkg srcpkg)
+new = eitherToLogProgress . mkInstallPlan . Graph.fromDistinctList
+
+-- | Build an installation plan from a graph of packages.
+new'
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ )
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> LogProgress (GenericInstallPlan ipkg srcpkg)
+new' = eitherToLogProgress . mkInstallPlan
toGraph
:: GenericInstallPlan ipkg srcpkg
@@ -381,13 +437,13 @@ toList = Foldable.toList . planGraph
toMap
:: GenericInstallPlan ipkg srcpkg
- -> Map UnitId (GenericPlanPackage ipkg srcpkg)
+ -> Map (Key ipkg) (GenericPlanPackage ipkg srcpkg)
toMap = Graph.toMap . planGraph
-keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
+keys :: GenericInstallPlan ipkg srcpkg -> [Key ipkg]
keys = Graph.keys . planGraph
-keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
+keysSet :: GenericInstallPlan ipkg srcpkg -> Set (Key ipkg)
keysSet = Graph.keysSet . planGraph
-- | Remove packages from the install plan. This will result in an
@@ -396,16 +452,15 @@ keysSet = Graph.keysSet . planGraph
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
remove
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ , Show (GraphKey ipkg srcpkg)
+ )
=> (GenericPlanPackage ipkg srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
- -> GenericInstallPlan ipkg srcpkg
+ -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan' (Key srcpkg) ipkg srcpkg)
remove shouldRemove plan =
- mkInstallPlan "remove" newGraph (planIndepGoals plan)
- where
- newGraph =
- Graph.fromDistinctList $
- filter (not . shouldRemove) (toList plan)
+ mkInstallPlan' $ Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan)
-- | Change a number of packages in the 'Configured' state to the 'Installed'
-- state.
@@ -413,7 +468,7 @@ remove shouldRemove plan =
-- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed').
installed
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: IsGraph ipkg srcpkg
=> (srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
@@ -432,11 +487,31 @@ installed shouldBeInstalled installPlan =
{ planGraph = Graph.insert (Installed pkg) (planGraph plan)
}
+-- | Change a number of packages in the 'Configured' state to the 'Installed'
+-- state.
+--
+-- To preserve invariants, the package must have all of its dependencies
+-- already installed too (that is 'PreExisting' or 'Installed').
+installedM
+ :: (IsGraph ipkg srcpkg, Monad m)
+ => (srcpkg -> m Bool)
+ -> GenericInstallPlan ipkg srcpkg
+ -> m (GenericInstallPlan ipkg srcpkg)
+installedM shouldBeInstalled installPlan = do
+ s <- filterM shouldBeInstalled [pkg | Configured pkg <- reverseTopologicalOrder installPlan]
+ return $ foldl markInstalled installPlan s
+ where
+ markInstalled plan pkg =
+ assert (all isInstalled (directDeps plan (nodeKey pkg))) $
+ plan
+ { planGraph = Graph.insert (Installed pkg) (planGraph plan)
+ }
+
-- | Lookup a package in the plan.
lookup
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: IsGraph ipkg srcpkg
=> GenericInstallPlan ipkg srcpkg
- -> UnitId
+ -> GraphKey ipkg srcpkg
-> Maybe (GenericPlanPackage ipkg srcpkg)
lookup plan pkgid = Graph.lookup pkgid (planGraph plan)
@@ -445,7 +520,7 @@ lookup plan pkgid = Graph.lookup pkgid (planGraph plan)
-- Note that the package must exist in the plan or it is an error.
directDeps
:: GenericInstallPlan ipkg srcpkg
- -> UnitId
+ -> GraphKey ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
directDeps plan pkgid =
case Graph.neighbors (planGraph plan) pkgid of
@@ -457,7 +532,7 @@ directDeps plan pkgid =
-- Note that the package must exist in the plan or it is an error.
revDirectDeps
:: GenericInstallPlan ipkg srcpkg
- -> UnitId
+ -> GraphKey ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
revDirectDeps plan pkgid =
case Graph.revNeighbors (planGraph plan) pkgid of
@@ -480,7 +555,7 @@ reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)
-- the given packages.
dependencyClosure
:: GenericInstallPlan ipkg srcpkg
- -> [UnitId]
+ -> [GraphKey ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
dependencyClosure plan =
fromMaybe []
@@ -490,7 +565,7 @@ dependencyClosure plan =
-- given packages.
reverseDependencyClosure
:: GenericInstallPlan ipkg srcpkg
- -> [UnitId]
+ -> [GraphKey ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
reverseDependencyClosure plan =
fromMaybe []
@@ -510,7 +585,11 @@ reverseDependencyClosure plan =
-- because that's not enough information.
fromSolverInstallPlan
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: ( HasCallStack
+ , IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ , Show (GraphKey ipkg srcpkg)
+ )
=> ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan.SolverPlanPackage
-> [GenericPlanPackage ipkg srcpkg]
@@ -518,39 +597,17 @@ fromSolverInstallPlan
-> SolverInstallPlan
-> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan f plan =
- mkInstallPlan
- "fromSolverInstallPlan"
- (Graph.fromDistinctList pkgs'')
- (SolverInstallPlan.planIndepGoals plan)
- where
- (_, _, pkgs'') =
- foldl'
- f'
- (Map.empty, Map.empty, [])
- (SolverInstallPlan.reverseTopologicalOrder plan)
-
- f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
- where
- pkgs' = f (mapDep pidMap ipiMap) pkg
-
- (pidMap', ipiMap') =
- case nodeKey pkg of
- PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
- PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
-
- mapDep _ ipiMap (PreExistingId _pid uid)
- | Just pkgs <- Map.lookup uid ipiMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
- mapDep pidMap _ (PlannedId pid)
- | Just pkgs <- Map.lookup pid pidMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
-
--- This shouldn't happen, since mapDep should only be called
--- on neighbor SolverId, which must have all been done already
--- by the reverse top-sort (we assume the graph is not broken).
+ either (error . show) id $
+ runLogProgress' $
+ fromSolverInstallPlanWithProgress
+ (\mapDep planpkg -> return $ f mapDep planpkg)
+ plan
fromSolverInstallPlanWithProgress
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ , Show (GraphKey ipkg srcpkg)
+ )
=> ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan.SolverPlanPackage
-> LogProgress [GenericPlanPackage ipkg srcpkg]
@@ -558,35 +615,22 @@ fromSolverInstallPlanWithProgress
-> SolverInstallPlan
-> LogProgress (GenericInstallPlan ipkg srcpkg)
fromSolverInstallPlanWithProgress f plan = do
- (_, _, pkgs'') <-
+ (_, pkgs'') <-
foldM
f'
- (Map.empty, Map.empty, [])
+ (Map.empty, [])
(SolverInstallPlan.reverseTopologicalOrder plan)
- return $
- mkInstallPlan
- "fromSolverInstallPlanWithProgress"
- (Graph.fromDistinctList pkgs'')
- (SolverInstallPlan.planIndepGoals plan)
+ new' (Graph.fromDistinctList pkgs'')
where
- f' (pidMap, ipiMap, pkgs) pkg = do
- pkgs' <- f (mapDep pidMap ipiMap) pkg
- let (pidMap', ipiMap') =
- case nodeKey pkg of
- PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
- PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
- return (pidMap', ipiMap', pkgs' ++ pkgs)
-
- mapDep _ ipiMap (PreExistingId _pid uid)
- | Just pkgs <- Map.lookup uid ipiMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
- mapDep pidMap _ (PlannedId pid)
- | Just pkgs <- Map.lookup pid pidMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
-
--- This shouldn't happen, since mapDep should only be called
--- on neighbor SolverId, which must have all been done already
--- by the reverse top-sort (we assume the graph is not broken).
+ f' (pMap, pkgs) pkg = do
+ pkgs' <- f (mapDep pMap) pkg
+ let pMap' = Map.insert (nodeKey pkg) pkgs' pMap
+ return (pMap', pkgs' ++ pkgs)
+
+ -- The error below shouldn't happen, since mapDep should only
+ -- be called on neighbor SolverId, which must have all been done
+ -- already by the reverse top-sort (we assume the graph is not broken).
+ mapDep pMap key = fromMaybe (error ("fromSolverInstallPlanWithProgress: " ++ prettyShow key)) (Map.lookup key pMap)
-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
-- Similar to 'elaboratedInstallPlan'
@@ -672,7 +716,7 @@ configureInstallPlan configFlags solverPlan =
-- and includes the set of packages that are in the processing state, e.g. in
-- the process of being installed, plus those that have been completed and
-- those where processing failed.
-data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
+data Processing key = Processing !(Set key) !(Set key) !(Set key)
-- processing, completed, failed
@@ -685,9 +729,13 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
-- all the packages that are ready will now be processed and so we can consider
-- them to be in the processing state.
ready
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: ( IsNode ipkg
+ , Key ipkg ~ key
+ , IsNode srcpkg
+ , Key srcpkg ~ key
+ )
=> GenericInstallPlan ipkg srcpkg
- -> ([GenericReadyPackage srcpkg], Processing)
+ -> ([GenericReadyPackage srcpkg], Processing key)
ready plan =
assert (processingInvariant plan processing) (readyPackages, processing)
where
@@ -712,11 +760,11 @@ isInstalled _ = False
-- process), along with the updated 'Processing' state.
completed
:: forall ipkg srcpkg
- . (IsUnit ipkg, IsUnit srcpkg)
+ . (IsGraph ipkg srcpkg, Ord (GraphKey ipkg srcpkg), Pretty (GraphKey ipkg srcpkg))
=> GenericInstallPlan ipkg srcpkg
- -> Processing
- -> UnitId
- -> ([GenericReadyPackage srcpkg], Processing)
+ -> Processing (GraphKey ipkg srcpkg)
+ -> (GraphKey ipkg srcpkg)
+ -> ([GenericReadyPackage srcpkg], Processing (GraphKey ipkg srcpkg))
completed plan (Processing processingSet completedSet failedSet) pkgid =
assert (pkgid `Set.member` processingSet) $
assert
@@ -748,11 +796,11 @@ completed plan (Processing processingSet completedSet failedSet) pkgid =
asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg
failed
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg))
=> GenericInstallPlan ipkg srcpkg
- -> Processing
- -> UnitId
- -> ([srcpkg], Processing)
+ -> Processing (GraphKey ipkg srcpkg)
+ -> GraphKey ipkg srcpkg
+ -> ([srcpkg], Processing (GraphKey ipkg srcpkg))
failed plan (Processing processingSet completedSet failedSet) pkgid =
assert (pkgid `Set.member` processingSet) $
assert (all (`Set.notMember` processingSet) (drop 1 newlyFailedIds)) $
@@ -778,9 +826,13 @@ failed plan (Processing processingSet completedSet failedSet) pkgid =
asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg
processingInvariant
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: ( IsNode ipkg
+ , Key ipkg ~ key
+ , IsNode srcpkg
+ , Key srcpkg ~ key
+ )
=> GenericInstallPlan ipkg srcpkg
- -> Processing
+ -> Processing key
-> Bool
processingInvariant plan (Processing processingSet completedSet failedSet) =
-- All the packages in the three sets are actually in the graph
@@ -859,7 +911,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
-- source packages in the dependency graph, albeit not necessarily exactly the
-- same ordering as that produced by 'reverseTopologicalOrder'.
executionOrder
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg))
=> GenericInstallPlan ipkg srcpkg
-> [GenericReadyPackage srcpkg]
executionOrder plan =
@@ -881,15 +933,15 @@ executionOrder plan =
-- ------------------------------------------------------------
-- | The set of results we get from executing an install plan.
-type BuildOutcomes failure result = Map UnitId (Either failure result)
+type BuildOutcomes key failure result = Map key (Either failure result)
-- | Lookup the build result for a single package.
lookupBuildOutcome
- :: HasUnitId pkg
+ :: (IsNode pkg, Key pkg ~ key)
=> pkg
- -> BuildOutcomes failure result
+ -> BuildOutcomes key failure result
-> Maybe (Either failure result)
-lookupBuildOutcome = Map.lookup . installedUnitId
+lookupBuildOutcome = Map.lookup . nodeKey
-- | Execute an install plan. This traverses the plan in dependency order.
--
@@ -907,29 +959,30 @@ lookupBuildOutcome = Map.lookup . installedUnitId
-- these will have no 'BuildOutcome'.
execute
:: forall m ipkg srcpkg result failure
- . ( IsUnit ipkg
- , IsUnit srcpkg
+ . ( IsGraph ipkg srcpkg
, Monad m
+ , Pretty (Key srcpkg)
)
- => JobControl m (UnitId, Either failure result)
+ => JobControl m (GraphKey ipkg srcpkg, Either failure result)
-> Bool
-- ^ Keep going after failure
-> (srcpkg -> failure)
-- ^ Value for dependents of failed packages
-> GenericInstallPlan ipkg srcpkg
-> (GenericReadyPackage srcpkg -> m (Either failure result))
- -> m (BuildOutcomes failure result)
+ -> m (BuildOutcomes (GraphKey ipkg srcpkg) failure result)
execute jobCtl keepGoing depFailure plan installPkg =
let (newpkgs, processing) = ready plan
- in tryNewTasks Map.empty False False processing newpkgs
+ in tryNewTasks mempty False False processing newpkgs
where
tryNewTasks
- :: BuildOutcomes failure result
+ :: (Pretty key, Key srcpkg ~ key)
+ => BuildOutcomes key failure result
-> Bool
-> Bool
- -> Processing
+ -> Processing key
-> [GenericReadyPackage srcpkg]
- -> m (BuildOutcomes failure result)
+ -> m (BuildOutcomes key failure result)
tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs
-- we were in the process of cancelling and now we're finished
@@ -956,11 +1009,12 @@ execute jobCtl keepGoing depFailure plan installPkg =
waitForTasks results tasksFailed processing
waitForTasks
- :: BuildOutcomes failure result
+ :: (Pretty key, Key srcpkg ~ key)
+ => BuildOutcomes key failure result
-> Bool
- -> Processing
- -> m (BuildOutcomes failure result)
- waitForTasks !results tasksFailed !processing = do
+ -> Processing key
+ -> m (BuildOutcomes key failure result)
+ waitForTasks results tasksFailed !processing = do
(pkgid, result) <- collectJob jobCtl
case result of
@@ -998,83 +1052,123 @@ execute jobCtl keepGoing depFailure plan installPkg =
-- ------------------------------------------------------------
--- | A valid installation plan is a set of packages that is closed, acyclic
--- and respects the package state relation.
---
--- * if the result is @False@ use 'problems' to get a detailed list.
-valid
- :: (IsUnit ipkg, IsUnit srcpkg)
- => String
- -> Graph (GenericPlanPackage ipkg srcpkg)
- -> Bool
-valid loc graph =
- case problems graph of
- [] -> True
- ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
-
data PlanProblem ipkg srcpkg
- = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
- | PackageCycle [GenericPlanPackage ipkg srcpkg]
+ = PackageMissingDeps
+ (GenericPlanPackage ipkg srcpkg)
+ -- ^ The package that is missing dependencies
+ (NonEmpty (GraphKey ipkg srcpkg))
+ -- ^ The missing dependencies
+ | -- | The packages involved in a dependency cycle
+ PackageCycle
+ [GenericPlanPackage ipkg srcpkg]
| PackageStateInvalid
(GenericPlanPackage ipkg srcpkg)
+ -- ^ The package that is in an invalid state
(GenericPlanPackage ipkg srcpkg)
+ -- ^ The package that it depends on which is in an invalid state
-showPlanProblem
- :: (IsUnit ipkg, IsUnit srcpkg)
+renderPlanProblems
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ )
+ => [PlanProblem ipkg srcpkg]
+ -> Doc
+renderPlanProblems =
+ vcat . map renderPlanProblem
+
+renderPlanProblem
+ :: ( IsGraph ipkg srcpkg
+ , Pretty (GraphKey ipkg srcpkg)
+ )
=> PlanProblem ipkg srcpkg
- -> String
-showPlanProblem (PackageMissingDeps pkg missingDeps) =
- "Package "
- ++ prettyShow (nodeKey pkg)
- ++ " depends on the following packages which are missing from the plan: "
- ++ intercalate ", " (map prettyShow missingDeps)
-showPlanProblem (PackageCycle cycleGroup) =
- "The following packages are involved in a dependency cycle "
- ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)
-showPlanProblem (PackageStateInvalid pkg pkg') =
- "Package "
- ++ prettyShow (nodeKey pkg)
- ++ " is in the "
- ++ showPlanPackageTag pkg
- ++ " state but it depends on package "
- ++ prettyShow (nodeKey pkg')
- ++ " which is in the "
- ++ showPlanPackageTag pkg'
- ++ " state"
+ -> Doc
+renderPlanProblem (PackageMissingDeps pkg missingDeps) =
+ fsep
+ [ text "Package"
+ , pretty (nodeKey pkg)
+ , text "depends on the following packages which are missing from the plan:"
+ , fsep (punctuate comma (map pretty $ NE.toList missingDeps))
+ ]
+renderPlanProblem (PackageCycle cycleGroup) =
+ fsep
+ [ text "The following packages are involved in a dependency cycle:"
+ , fsep (punctuate comma (map (pretty . nodeKey) cycleGroup))
+ ]
+renderPlanProblem (PackageStateInvalid pkg pkg') =
+ fsep
+ [ text "Package"
+ , pretty (nodeKey pkg)
+ , text "is in the"
+ , renderPlanPackageTag pkg
+ , text "state but it depends on package"
+ , pretty (nodeKey pkg')
+ , text "which is in the"
+ , renderPlanPackageTag pkg'
+ , text "state"
+ ]
-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
problems
- :: (IsUnit ipkg, IsUnit srcpkg)
+ :: IsGraph ipkg srcpkg
=> Graph (GenericPlanPackage ipkg srcpkg)
-> [PlanProblem ipkg srcpkg]
problems graph =
+ concat
+ [ checkForMissingDeps graph
+ , checkForCycles graph
+ , -- , checkForDependencyInconsistencies graph
+ checkForPackageStateInconsistencies graph
+ ]
+
+checkForMissingDeps
+ :: IsGraph ipkg srcpkg
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> [PlanProblem ipkg srcpkg]
+checkForMissingDeps graph =
[ PackageMissingDeps
pkg
- ( mapMaybe
- (fmap nodeKey . flip Graph.lookup graph)
- missingDeps
- )
+ missingDeps
| (pkg, missingDeps) <- Graph.broken graph
]
- ++ [ PackageCycle cycleGroup
- | cycleGroup <- Graph.cycles graph
- ]
- {-
- ++ [ PackageInconsistency name inconsistencies
- | (name, inconsistencies) <-
- dependencyInconsistencies indepGoals graph ]
- --TODO: consider re-enabling this one, see SolverInstallPlan
- -}
- ++ [ PackageStateInvalid pkg pkg'
- | pkg <- Foldable.toList graph
- , Just pkg' <-
- map
- (`Graph.lookup` graph)
- (nodeNeighbors pkg)
- , not (stateDependencyRelation pkg pkg')
- ]
+
+checkForCycles
+ :: IsGraph ipkg srcpkg
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> [PlanProblem ipkg srcpkg]
+checkForCycles graph =
+ [PackageCycle cycleGroup | cycleGroup <- Graph.cycles graph]
+
+-- TODO: consider re-enabling this one, see SolverInstallPlan
+--
+-- checkForDependencyInconsistencies
+-- :: ( IsGraph ipkg srcpkg
+-- , Pretty (GraphKey ipkg srcpkg)
+-- , Key srcpkg ~ PlanProblem ipkg srcpkg
+-- , Key ipkg ~ GraphKey ipkg srcpkg
+-- )
+-- => Graph (GenericPlanPackage ipkg srcpkg)
+-- -> [PlanProblem ipkg srcpkg]
+-- checkForDependencyInconsistencies graph =
+-- [ PackageInconsistency name inconsistencies
+-- | (name, inconsistencies) <-
+-- dependencyInconsistencies indepGoals graph
+-- ]
+
+checkForPackageStateInconsistencies
+ :: IsGraph ipkg srcpkg
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> [PlanProblem ipkg srcpkg]
+checkForPackageStateInconsistencies graph =
+ [ PackageStateInvalid pkg pkg'
+ | pkg <- Foldable.toList graph
+ , Just pkg' <-
+ map
+ (flip Graph.lookup graph)
+ (nodeNeighbors pkg)
+ , not (stateDependencyRelation pkg pkg')
+ ]
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs
index a3a4fbec6b0..959e1f20a3d 100644
--- a/cabal-install/src/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs
@@ -61,10 +61,9 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.Setup
( ConfigFlags (..)
, flagToMaybe
- , fromFlag
, fromFlagOrDefault
)
-import Distribution.Simple.Utils (info, withTempDirectory)
+import Distribution.Simple.Utils (info, removeFileForcibly, withTempDirectory)
import Distribution.System
( Platform
)
@@ -79,7 +78,6 @@ import System.Directory
, getSymbolicLinkTarget
, getTemporaryDirectory
, pathIsSymbolicLink
- , removeFile
)
import System.FilePath
( isAbsolute
@@ -97,6 +95,7 @@ import System.IO.Error
, isDoesNotExistError
)
+import Distribution.Client.Config (defaultUserInstall)
import Distribution.Client.Init.Prompt (promptYesNo)
import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt), runPromptIO)
import Distribution.Client.Types.OverwritePolicy
@@ -219,7 +218,7 @@ symlinkBinaries
defaultDirs <-
InstallDirs.defaultInstallDirs
compilerFlavor
- (fromFlag (configUserInstall configFlags))
+ (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags))
(PackageDescription.hasLibs pkg)
let templateDirs =
InstallDirs.combineInstallDirs
@@ -322,7 +321,7 @@ symlinkBinary inputs@Symlink{publicBindir, privateBindir, publicName, privateNam
mkLink = True <$ createFileLink (relativeBindir privateName) (publicBindir publicName)
rmLink :: IO Bool
- rmLink = True <$ removeFile (publicBindir publicName)
+ rmLink = True <$ removeFileForcibly (publicBindir publicName)
overwrite :: IO Bool
overwrite = rmLink *> mkLink
diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs
index 280916fdf6c..d37397987d3 100644
--- a/cabal-install/src/Distribution/Client/JobControl.hs
+++ b/cabal-install/src/Distribution/Client/JobControl.hs
@@ -50,7 +50,6 @@ import Control.Monad (forever, replicateM_)
import Distribution.Client.Compat.Semaphore
import Distribution.Client.Utils (numberOfProcessors)
import Distribution.Compat.Stack
-import Distribution.Simple.Compiler
import Distribution.Simple.Utils
import Distribution.Types.ParStrat
import System.Semaphore
@@ -277,29 +276,15 @@ criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
newJobControlFromParStrat
:: Verbosity
- -> Maybe Compiler
- -- ^ The compiler, used to determine whether Jsem is supported.
- -- When Nothing, Jsem is assumed to be unsupported.
-> ParStratInstall
-- ^ The parallel strategy
-> Maybe Int
-- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy)
-> IO (JobControl IO a)
-newJobControlFromParStrat verbosity mcompiler parStrat numJobsCap = case parStrat of
+newJobControlFromParStrat verbosity parStrat numJobsCap = case parStrat of
Serial -> newSerialJobControl
NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n))
- UseSem n ->
- case mcompiler of
- Just compiler
- | jsemSupported compiler ->
- newSemaphoreJobControl verbosity (capJobs n)
- | otherwise ->
- do
- warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
- newParallelJobControl (capJobs n)
- Nothing ->
- -- Don't warn in the Nothing case, as there isn't really a "selected" compiler.
- newParallelJobControl (capJobs n)
+ UseSem n -> newSemaphoreJobControl verbosity (capJobs n)
where
capJobs n = min (fromMaybe maxBound numJobsCap) n
diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs
index d571851a8e2..fc49cb5148d 100644
--- a/cabal-install/src/Distribution/Client/Main.hs
+++ b/cabal-install/src/Distribution/Client/Main.hs
@@ -101,6 +101,7 @@ import Distribution.Client.Config
( SavedConfig (..)
, createDefaultConfigFile
, defaultConfigFile
+ , defaultUserInstall
, getConfigFilePath
, loadConfig
, userConfigDiff
@@ -111,7 +112,8 @@ import qualified Distribution.Client.List as List
, list
)
import Distribution.Client.SetupWrapper
- ( SetupScriptOptions (..)
+ ( SetupRunnerArgs (NotInLibrary)
+ , SetupScriptOptions (..)
, defaultSetupScriptOptions
, setupWrapper
)
@@ -322,7 +324,7 @@ main args = do
-- for more information.
let (args0, args1) = break (== "--") args
- mainWorker =<< (++ args1) <$> expandResponse args0
+ mainWorker . (++ args1) =<< expandResponse args0
-- | Check whether assertions are enabled and print a warning in that case.
warnIfAssertionsAreEnabled :: IO ()
@@ -537,7 +539,7 @@ wrapperCmd
-> (flags -> CommonSetupFlags)
-> CommandSpec Action
wrapperCmd ui getCommonFlags =
- CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand
+ CommandSpec ui (`wrapperAction` getCommonFlags) NormalCommand
wrapperAction
:: Monoid flags
@@ -572,6 +574,7 @@ wrapperAction command getCommonFlags =
getCommonFlags
(const (return flags))
(const extraArgs)
+ NotInLibrary
configureAction
:: (ConfigFlags, ConfigExFlags)
@@ -600,7 +603,7 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do
let packageDBs :: PackageDBStack
packageDBs =
interpretPackageDbFlags
- (fromFlag (configUserInstall configFlags'))
+ (fromFlagOrDefault defaultUserInstall (configUserInstall configFlags'))
(configPackageDBs configFlags')
withRepoContext verbosity globalFlags' $ \repoContext ->
@@ -687,6 +690,7 @@ build verbosity config distPref buildFlags extraArgs =
buildCommonFlags
(return . mkBuildFlags)
(const extraArgs)
+ NotInLibrary
where
progDb = defaultProgramDb
setupOptions = defaultSetupScriptOptions{useDistPref = distPref}
@@ -782,6 +786,7 @@ replAction replFlags extraArgs globalFlags = do
Cabal.replCommonFlags
(const (return replFlags'))
(const extraArgs)
+ NotInLibrary
-- No .cabal file in the current directory: just start the REPL (possibly
-- using the sandbox package DB).
@@ -831,6 +836,7 @@ installAction (configFlags, _, installFlags, _, _, _) _ globalFlags
(const common)
(const (return (mempty, mempty, mempty, mempty, mempty, mempty)))
(const [])
+ NotInLibrary
installAction
( configFlags
, configExFlags
@@ -1004,6 +1010,7 @@ testAction (buildFlags, testFlags) extraArgs globalFlags = do
Cabal.testCommonFlags
(const (return testFlags'))
(const extraArgs')
+ NotInLibrary
data ComponentNames
= ComponentNamesUnknown
@@ -1127,6 +1134,7 @@ benchmarkAction
Cabal.benchmarkCommonFlags
(const (return benchmarkFlags'))
(const extraArgs')
+ NotInLibrary
haddockAction :: HaddockFlags -> [String] -> Action
haddockAction haddockFlags extraArgs globalFlags = do
@@ -1171,6 +1179,7 @@ haddockAction haddockFlags extraArgs globalFlags = do
haddockCommonFlags
(const (return haddockFlags'))
(const extraArgs)
+ NotInLibrary
when (haddockForHackage haddockFlags == Flag ForHackage) $ do
pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig mbWorkDir distPref)
@@ -1210,6 +1219,7 @@ cleanAction cleanFlags extraArgs globalFlags = do
cleanCommonFlags
(const (return cleanFlags'))
(const extraArgs)
+ NotInLibrary
listAction :: ListFlags -> [String] -> Action
listAction listFlags extraArgs globalFlags = do
diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs
index 3a94c0e028b..227a1792691 100644
--- a/cabal-install/src/Distribution/Client/PackageHash.hs
+++ b/cabal-install/src/Distribution/Client/PackageHash.hs
@@ -182,7 +182,8 @@ data PackageHashInputs = PackageHashInputs
, pkgHashComponent :: Maybe CD.Component
, pkgHashSourceHash :: PackageSourceHash
, pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion)
- , pkgHashDirectDeps :: Set InstalledPackageId
+ , pkgHashLibDeps :: Set InstalledPackageId
+ , pkgHashExeDeps :: Set InstalledPackageId
, pkgHashOtherConfig :: PackageHashConfigInputs
}
@@ -220,7 +221,7 @@ data PackageHashConfigInputs = PackageHashConfigInputs
, pkgHashExtraIncludeDirs :: [FilePath]
, pkgHashProgPrefix :: Maybe PathTemplate
, pkgHashProgSuffix :: Maybe PathTemplate
- , pkgHashPackageDbs :: [Maybe PackageDBCWD]
+ , pkgHashPackageDbs :: [PackageDBCWD]
, -- Haddock options
pkgHashDocumentation :: Bool
, pkgHashHaddockHoogle :: Bool
@@ -258,7 +259,8 @@ renderPackageHashInputs
{ pkgHashPkgId
, pkgHashComponent
, pkgHashSourceHash
- , pkgHashDirectDeps
+ , pkgHashLibDeps
+ , pkgHashExeDeps
, pkgHashPkgConfigDeps
, pkgHashOtherConfig =
PackageHashConfigInputs{..}
@@ -297,12 +299,19 @@ renderPackageHashInputs
)
pkgHashPkgConfigDeps
, entry
- "deps"
+ "lib-deps"
( intercalate ", "
. map prettyShow
. Set.toList
)
- pkgHashDirectDeps
+ pkgHashLibDeps
+ , entry
+ "exe-deps"
+ ( intercalate ", "
+ . map prettyShow
+ . Set.toList
+ )
+ pkgHashExeDeps
, -- and then all the config
entry "compilerid" prettyShow pkgHashCompilerId
, entry "compilerabi" prettyShow pkgHashCompilerABI
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index b2f24efc5d6..53eddd56baf 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -57,7 +58,6 @@ import Distribution.Client.GlobalFlags (RepoContext)
import Distribution.Client.InstallPlan
( GenericInstallPlan
, GenericPlanPackage
- , IsUnit
)
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.JobControl
@@ -71,7 +71,6 @@ import Distribution.Client.Types hiding
import Distribution.Package
import Distribution.Simple.Compiler
-import Distribution.Simple.Program
import qualified Distribution.Simple.Register as Cabal
import Distribution.Compat.Graph (IsNode (..))
@@ -97,6 +96,7 @@ import Distribution.Simple.Flag (fromFlagOrDefault)
import Distribution.Client.ProjectBuilding.PackageFileMonitor
import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
+import qualified Distribution.Compat.Graph as Graph
------------------------------------------------------------------------------
@@ -259,21 +259,26 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
-- visiting function is passed the results for all the immediate package
-- dependencies. This can be used to propagate information from dependencies.
foldMInstallPlanDepOrder
- :: forall m ipkg srcpkg b
- . (Monad m, IsUnit ipkg, IsUnit srcpkg)
+ :: forall m ipkg srcpkg b key
+ . ( Monad m
+ , IsNode ipkg
+ , Key ipkg ~ key
+ , IsNode srcpkg
+ , Key srcpkg ~ key
+ )
=> ( GenericPlanPackage ipkg srcpkg
-> [b]
-> m b
)
-> GenericInstallPlan ipkg srcpkg
- -> m (Map UnitId b)
+ -> m (Map key b)
foldMInstallPlanDepOrder visit =
go Map.empty . InstallPlan.reverseTopologicalOrder
where
go
- :: Map UnitId b
+ :: Map key b
-> [GenericPlanPackage ipkg srcpkg]
- -> m (Map UnitId b)
+ -> m (Map key b)
go !results [] = return results
go !results (pkg : pkgs) = do
-- we go in the right order so the results map has entries for all deps
@@ -298,7 +303,7 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
where
canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
canPackageBeImproved pkg =
- case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
+ case Map.lookup (nodeKey pkg) pkgsBuildStatus of
Just BuildStatusUpToDate{} -> True
Just _ -> False
Nothing ->
@@ -335,26 +340,67 @@ rebuildTargets
-> BuildTimeSettings
-> IO BuildOutcomes
rebuildTargets
+ verbosity
+ projectConfig
+ distDirLayout
+ storeDirLayout
+ installPlan
+ sharedPackageConfig
+ pkgsBuildStatus
+ buildSettings
+ | buildSettingOnlyDownload buildSettings = do
+ rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $
+ \downloadMap _jobControl pkg pkgBuildStatus ->
+ rebuildTargetOnlyDownload
+ verbosity
+ downloadMap
+ pkg
+ pkgBuildStatus
+ | otherwise = do
+ registerLock <- newLock -- serialise registration
+ cacheLock <- newLock -- serialise access to setup exe cache
+ rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $
+ \downloadMap jobControl pkg pkgBuildStatus ->
+ rebuildTarget
+ verbosity
+ distDirLayout
+ storeDirLayout
+ (jobControlSemaphore jobControl)
+ buildSettings
+ downloadMap
+ registerLock
+ cacheLock
+ sharedPackageConfig
+ installPlan
+ pkg
+ pkgBuildStatus
+
+rebuildTargets'
+ :: Verbosity
+ -> ProjectConfig
+ -> DistDirLayout
+ -> ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> BuildStatusMap
+ -> BuildTimeSettings
+ -> (AsyncFetchMap -> JobControl IO (Graph.Key (GenericReadyPackage ElaboratedConfiguredPackage), Either BuildFailure BuildResult) -> GenericReadyPackage ElaboratedConfiguredPackage -> BuildStatus -> IO BuildResult)
+ -> IO BuildOutcomes
+rebuildTargets'
verbosity
ProjectConfig
{ projectConfigBuildOnly = config
}
- distDirLayout@DistDirLayout{..}
- storeDirLayout
+ DistDirLayout{..}
installPlan
- sharedPackageConfig@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = progdb
- }
+ sharedPackageConfig
pkgsBuildStatus
buildSettings@BuildTimeSettings
{ buildSettingNumJobs
, buildSettingKeepGoing
}
+ act
| fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
| otherwise = do
- registerLock <- newLock -- serialise registration
- cacheLock <- newLock -- serialise access to setup exe cache
-- TODO: [code cleanup] eliminate setup exe cache
info verbosity $
"Executing install plan "
@@ -365,11 +411,11 @@ rebuildTargets
createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
createDirectoryIfMissingVerbose verbosity True distTempDirectory
- traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
+ createPackageDBsIfMissing
-- Concurrency control: create the job controller and concurrency limits
-- for downloading, building and installing.
- withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do
+ withJobControl (newJobControlFromParStrat verbosity buildSettingNumJobs Nothing) $ \jobControl -> do
-- Before traversing the install plan, preemptively find all packages that
-- will need to be downloaded and start downloading them.
asyncDownloadPackages
@@ -382,56 +428,53 @@ rebuildTargets
InstallPlan.execute
jobControl
keepGoing
- (BuildFailure Nothing . DependentFailed . packageId)
+ (BuildFailure Nothing . DependentFailed . Graph.nodeKey)
installPlan
$ \pkg ->
-- TODO: review exception handling
handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do
- let uid = installedUnitId pkg
- pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus
-
- rebuildTarget
- verbosity
- distDirLayout
- storeDirLayout
- (jobControlSemaphore jobControl)
- buildSettings
- downloadMap
- registerLock
- cacheLock
- sharedPackageConfig
- installPlan
- pkg
- pkgBuildStatus
+ let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus
+ act downloadMap jobControl pkg pkgBuildStatus
where
keepGoing = buildSettingKeepGoing
withRepoCtx =
projectConfigWithBuilderRepoContext
verbosity
buildSettings
- packageDBsToUse =
- -- all the package dbs we may need to create
- (Set.toList . Set.fromList)
- [ pkgdb
- | InstallPlan.Configured elab <- InstallPlan.toList installPlan
- , pkgdb <-
- concat
- [ elabBuildPackageDBStack elab
- , elabRegisterPackageDBStack elab
- , elabSetupPackageDBStack elab
- ]
- ]
+
+ createPackageDBsIfMissing :: IO ()
+ createPackageDBsIfMissing =
+ for_ (InstallPlan.toList installPlan) $ \case
+ InstallPlan.Configured elab -> do
+ let pkgdbs =
+ (Set.toList . Set.fromList) $
+ concat
+ [ elabBuildPackageDBStack elab
+ , elabRegisterPackageDBStack elab
+ , elabSetupPackageDBStack elab
+ ]
+ for_ pkgdbs $ \case
+ SpecificPackageDB dbPath -> do
+ exists <- Cabal.doesPackageDBExist dbPath
+ let Toolchain{toolchainCompiler, toolchainProgramDb} =
+ getStage (pkgConfigToolchains sharedPackageConfig) (elabStage elab)
+ unless exists $ do
+ createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
+ Cabal.createPackageDB verbosity toolchainCompiler toolchainProgramDb dbPath
+ _ -> pure ()
+ _ -> pure ()
offlineError :: BuildOutcomes
offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload
where
- makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome)
+ makeBuildOutcome :: ElaboratedConfiguredPackage -> (Graph.Key ElaboratedPlanPackage, BuildOutcome)
makeBuildOutcome
ElaboratedConfiguredPackage
{ elabUnitId
+ , elabStage
, elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion}
} =
- ( elabUnitId
+ ( WithStage elabStage elabUnitId
, Left
( BuildFailure
{ buildFailureLogFile = Nothing
@@ -457,25 +500,6 @@ rebuildTargets
isRemote (RemoteSourceRepoPackage _ _) = True
isRemote _ = False
--- | Create a package DB if it does not currently exist. Note that this action
--- is /not/ safe to run concurrently.
-createPackageDBIfMissing
- :: Verbosity
- -> Compiler
- -> ProgramDb
- -> PackageDBCWD
- -> IO ()
-createPackageDBIfMissing
- verbosity
- compiler
- progdb
- (SpecificPackageDB dbPath) = do
- exists <- Cabal.doesPackageDBExist dbPath
- unless exists $ do
- createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
- Cabal.createPackageDB verbosity compiler progdb False dbPath
-createPackageDBIfMissing _ _ _ _ = return ()
-
-- | Given all the context and resources, (re)build an individual package.
rebuildTarget
:: Verbosity
@@ -518,7 +542,8 @@ rebuildTarget
void $ waitAsyncPackageDownload verbosity downloadMap pkg
_ -> return ()
return $ BuildResult DocsNotTried TestsNotTried Nothing
- | otherwise =
+ | otherwise = do
+ info verbosity $ "[rebuildTarget] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " with current status " ++ buildStatusToString pkgBuildStatus
-- We rely on the 'BuildStatus' to decide which phase to start from:
case pkgBuildStatus of
BuildStatusDownload -> downloadPhase
@@ -561,7 +586,8 @@ rebuildTarget
-- would only start from download or unpack phases.
--
rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult
- rebuildPhase buildStatus srcdir =
+ rebuildPhase buildStatus srcdir = do
+ info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir
assert
(isInplaceBuildStyle $ elabBuildStyle pkg)
buildInplace
@@ -576,7 +602,8 @@ rebuildTarget
-- TODO: [nice to have] ^^ do this relative stuff better
buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult
- buildAndInstall srcdir builddir =
+ buildAndInstall srcdir builddir = do
+ info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir
buildAndInstallUnpackedPackage
verbosity
distDirLayout
@@ -592,8 +619,9 @@ rebuildTarget
builddir
buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult
- buildInplace buildStatus srcdir builddir =
+ buildInplace buildStatus srcdir builddir = do
-- TODO: [nice to have] use a relative build dir rather than absolute
+ info verbosity $ "[buildInplace] Building inplace " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir
buildInplaceUnpackedPackage
verbosity
distDirLayout
@@ -608,6 +636,23 @@ rebuildTarget
srcdir
builddir
+rebuildTargetOnlyDownload
+ :: Verbosity
+ -> AsyncFetchMap
+ -> GenericReadyPackage ElaboratedConfiguredPackage
+ -> BuildStatus
+ -> IO BuildResult
+rebuildTargetOnlyDownload
+ verbosity
+ downloadMap
+ (ReadyPackage pkg)
+ pkgBuildStatus = do
+ case pkgBuildStatus of
+ BuildStatusDownload ->
+ void $ waitAsyncPackageDownload verbosity downloadMap pkg
+ _ -> return ()
+ return $ BuildResult DocsNotTried TestsNotTried Nothing
+
-- TODO: [nice to have] do we need to use a with-style for the temp
-- files for downloading http packages, or are we going to cache them
-- persistently?
@@ -642,8 +687,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
[ elabPkgSourceLocation elab
| InstallPlan.Configured elab <-
InstallPlan.reverseTopologicalOrder installPlan
- , let uid = installedUnitId elab
- pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
+ , let pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") (Graph.nodeKey elab) pkgsBuildStatus
, BuildStatusDownload <- [pkgBuildStatus]
]
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
index 71d31cb5926..78aa1b5b587 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
@@ -24,9 +24,9 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Simple.LocalBuildInfo
( ComponentName (..)
)
+import Distribution.Simple.Utils (removeFileForcibly)
import qualified Data.Set as Set
-import Distribution.Client.Init.Types (removeExistingFile, runPromptIO)
-----------------------------
-- Package change detection
@@ -291,4 +291,4 @@ updatePackageRegFileMonitor
invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
- runPromptIO $ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
+ removeFileForcibly (fileMonitorCacheFile pkgFileMonitorReg)
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs
index 864455cb540..8a54b494f76 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs
@@ -25,8 +25,9 @@ import Prelude ()
import Distribution.Client.FileMonitor (MonitorChangedReason (..))
import Distribution.Client.Types (DocsResult, TestsResult)
+import Distribution.Client.ProjectPlanning.Types (ElaboratedConfiguredPackage, ElaboratedPlanPackage)
+import qualified Distribution.Compat.Graph as Graph
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-import Distribution.Package (PackageId, UnitId)
import Distribution.Simple.LocalBuildInfo (ComponentName)
------------------------------------------------------------------------------
@@ -36,7 +37,7 @@ import Distribution.Simple.LocalBuildInfo (ComponentName)
-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.
--
-- This is used as the result of the dry-run of building an install plan.
-type BuildStatusMap = Map UnitId BuildStatus
+type BuildStatusMap = Map (Graph.Key ElaboratedPlanPackage) BuildStatus
-- | The build status for an individual package is the state that the
-- package is in /prior/ to initiating a (re)build.
@@ -135,7 +136,7 @@ data BuildReason
--
-- | A summary of the outcome for building a whole set of packages.
-type BuildOutcomes = Map UnitId BuildOutcome
+type BuildOutcomes = Map (Graph.Key ElaboratedPlanPackage) BuildOutcome
-- | A summary of the outcome for building a single package: either success
-- or failure.
@@ -160,7 +161,7 @@ instance Exception BuildFailure
-- | Detail on the reason that a package failed to build.
data BuildFailureReason
- = DependentFailed PackageId
+ = DependentFailed (Graph.Key ElaboratedConfiguredPackage)
| GracefulFailure String
| DownloadFailed SomeException
| UnpackFailed SomeException
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
index e66428ef1c3..2518d96599f 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -1,7 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -80,43 +82,50 @@ import Distribution.Simple.Compiler
( PackageDBStackCWD
, coercePackageDBStack
)
+import qualified Distribution.Simple.Configure as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
( ComponentName (..)
, LibraryName (..)
)
+import qualified Distribution.Simple.LocalBuildInfo as Cabal
import Distribution.Simple.Program
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.Setup as Cabal
+
import Distribution.Types.BuildType
import Distribution.Types.PackageDescription.Lens (componentModules)
+import Distribution.Client.Errors
import Distribution.Simple.Utils
-import Distribution.System (Platform (..))
import Distribution.Utils.Path hiding
( (<.>)
, ()
)
+import Distribution.Verbosity (setVerbosityHandles)
import Distribution.Version
+import Distribution.Client.ProjectBuilding.PackageFileMonitor
+
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
import qualified Data.List.NonEmpty as NE
import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeFile)
+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, listDirectory)
import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ())
import System.IO (Handle, IOMode (AppendMode), withFile)
import System.Semaphore (SemaphoreName (..))
+import GHC.Stack
import Web.Browser (openBrowser)
import Distribution.Client.Errors
import Distribution.Client.ProjectBuilding.PackageFileMonitor
-import Distribution.Verbosity (setVerbosityHandles)
-
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.System (Platform (..))
-- | Each unpacked package is processed in the following phases:
--
-- * Configure phase
@@ -131,20 +140,21 @@ import Distribution.Verbosity (setVerbosityHandles)
-- Depending on whether we are installing the package or building it inplace,
-- the phases will be carried out differently. For example, when installing,
-- the test, benchmark, and repl phase are ignored.
-data PackageBuildingPhase
- = PBConfigurePhase {runConfigure :: IO ()}
- | PBBuildPhase {runBuild :: IO ()}
- | PBHaddockPhase {runHaddock :: IO ()}
- | PBInstallPhase
- { runCopy :: FilePath -> IO ()
- , runRegister
+data PackageBuildingPhase r where
+ PBConfigurePhase :: {runConfigure :: IO InLibraryLBI} -> PackageBuildingPhase InLibraryLBI
+ PBBuildPhase :: {runBuild :: IO [MonitorFilePath]} -> PackageBuildingPhase ()
+ PBHaddockPhase :: {runHaddock :: IO [MonitorFilePath]} -> PackageBuildingPhase ()
+ PBReplPhase :: {runRepl :: IO [MonitorFilePath]} -> PackageBuildingPhase ()
+ PBInstallPhase
+ :: { runCopy :: FilePath -> IO ()
+ , runRegister
:: PackageDBStackCWD
-> Cabal.RegisterOptions
-> IO InstalledPackageInfo
- }
- | PBTestPhase {runTest :: IO ()}
- | PBBenchPhase {runBench :: IO ()}
- | PBReplPhase {runRepl :: IO ()}
+ }
+ -> PackageBuildingPhase ()
+ PBTestPhase :: {runTest :: IO ()} -> PackageBuildingPhase ()
+ PBBenchPhase :: {runBench :: IO ()} -> PackageBuildingPhase ()
-- | Structures the phases of building and registering a package amongst others
-- (see t'PackageBuildingPhase'). Delegates logic specific to a certain
@@ -167,62 +177,70 @@ buildAndRegisterUnpackedPackage
-> SymbolicPath Pkg (Dir Dist)
-> Maybe FilePath
-- ^ The path to an /initialized/ log file
- -> (PackageBuildingPhase -> IO ())
+ -> (forall r. PackageBuildingPhase r -> IO r)
-> IO ()
buildAndRegisterUnpackedPackage
verbosity
distDirLayout@DistDirLayout{distTempDirectory}
maybe_semaphore
- buildTimeSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingKeepTempFiles}
+ buildTimeSettings@BuildTimeSettings{buildSettingKeepTempFiles}
registerLock
cacheLock
- pkgshared@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = progdb
- }
+ pkgshared
plan
rpkg@(ReadyPackage pkg)
srcdir
builddir
mlogFile
delegate = do
+ info verbosity $ "\n\nbuildAndRegisterUnpackedPackage: " ++ prettyShow (Graph.nodeKey pkg)
-- Configure phase
- delegate $
- PBConfigurePhase $
- annotateFailure mlogFile ConfigureFailed $
- setup configureCommand Cabal.configCommonFlags configureFlags configureArgs
+ mbLBI <-
+ delegate $
+ PBConfigurePhase $
+ annotateFailure mlogFile ConfigureFailed $ do
+ info verbosity $ "--- Configure phase " ++ prettyShow (Graph.nodeKey pkg)
+ setup configureCommand Cabal.configCommonFlags configureFlags configureArgs
+ (InLibraryArgs $ InLibraryConfigureArgs pkgshared rpkg)
-- Build phase
delegate $
PBBuildPhase $
annotateFailure mlogFile BuildFailed $ do
+ info verbosity $ "--- Build phase " ++ prettyShow (Graph.nodeKey pkg)
setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs
+ (InLibraryArgs $ InLibraryPostConfigureArgs SBuildPhase mbLBI)
-- Haddock phase
whenHaddock $
delegate $
PBHaddockPhase $
annotateFailure mlogFile HaddocksFailed $ do
+ info verbosity $ "--- Haddock phase " ++ prettyShow (Graph.nodeKey pkg)
setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs
+ (InLibraryArgs $ InLibraryPostConfigureArgs SHaddockPhase mbLBI)
-- Install phase
delegate $
PBInstallPhase
{ runCopy = \destdir ->
- annotateFailure mlogFile InstallFailed $
+ annotateFailure mlogFile InstallFailed $ do
+ info verbosity $ "--- Install phase, copy " ++ prettyShow (Graph.nodeKey pkg)
setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs
+ (InLibraryArgs $ InLibraryPostConfigureArgs SCopyPhase mbLBI)
, runRegister = \pkgDBStack registerOpts ->
annotateFailure mlogFile InstallFailed $ do
+ info verbosity $ "--- Install phase, register " ++ prettyShow (Graph.nodeKey pkg)
-- We register ourselves rather than via Setup.hs. We need to
-- grab and modify the InstalledPackageInfo. We decide what
-- the installed package id is, not the build system.
- ipkg0 <- generateInstalledPackageInfo
+ ipkg0 <- generateInstalledPackageInfo mbLBI
let ipkg = ipkg0{Installed.installedUnitId = uid}
criticalSection registerLock $
Cabal.registerPackage
verbosity
- compiler
- progdb
+ toolchainCompiler
+ toolchainProgramDb
Nothing
(coercePackageDBStack pkgDBStack)
ipkg
@@ -234,27 +252,36 @@ buildAndRegisterUnpackedPackage
whenTest $
delegate $
PBTestPhase $
- annotateFailure mlogFile TestsFailed $
+ annotateFailure mlogFile TestsFailed $ do
+ info verbosity $ "--- Test phase " ++ prettyShow (Graph.nodeKey pkg)
setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs
+ (InLibraryArgs $ InLibraryPostConfigureArgs STestPhase mbLBI)
-- Bench phase
whenBench $
delegate $
PBBenchPhase $
- annotateFailure mlogFile BenchFailed $
+ annotateFailure mlogFile BenchFailed $ do
+ info verbosity $ "--- Benchmark phase " ++ prettyShow (Graph.nodeKey pkg)
setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs
+ (InLibraryArgs $ InLibraryPostConfigureArgs SBenchPhase mbLBI)
-- Repl phase
whenRepl $
delegate $
PBReplPhase $
- annotateFailure mlogFile ReplFailed $
- setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs
+ annotateFailure mlogFile ReplFailed $ do
+ info verbosity $ "--- Repl phase " ++ prettyShow (Graph.nodeKey pkg)
+ setupInteractive replCommand Cabal.replCommonFlags (return . replFlags) replArgs
+ (InLibraryArgs $ InLibraryPostConfigureArgs SReplPhase mbLBI)
return ()
where
uid = installedUnitId rpkg
+ Toolchain{toolchainCompiler, toolchainProgramDb} =
+ getStage (pkgConfigToolchains pkgshared) (elabStage pkg)
+
comp_par_strat = case maybe_semaphore of
Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name)
_ -> Cabal.NoFlag
@@ -276,17 +303,18 @@ buildAndRegisterUnpackedPackage
| otherwise = return ()
mbWorkDir = useWorkingDir scriptOptions
- commonFlags = setupHsCommonFlags verbosity mbWorkDir builddir buildSettingKeepTempFiles
+ commonFlags targets =
+ setupHsCommonFlags verbosity mbWorkDir builddir targets buildSettingKeepTempFiles
configureCommand = Cabal.configureCommand defaultProgramDb
configureFlags v =
flip filterConfigureFlags v
<$> setupHsConfigureFlags
- (\p -> makeSymbolicPath <$> canonicalizePath p)
+ (fmap makeSymbolicPath . canonicalizePath)
plan
rpkg
pkgshared
- commonFlags
+ (commonFlags $ configureArgs v)
configureArgs _ = setupHsConfigureArgs pkg
buildCommand = Cabal.buildCommand defaultProgramDb
@@ -296,7 +324,7 @@ buildAndRegisterUnpackedPackage
comp_par_strat
pkg
pkgshared
- commonFlags
+ (commonFlags $ buildArgs v)
buildArgs _ = setupHsBuildArgs pkg
copyFlags destdir v =
@@ -304,7 +332,7 @@ buildAndRegisterUnpackedPackage
setupHsCopyFlags
pkg
pkgshared
- commonFlags
+ (commonFlags $ buildArgs v)
destdir
-- In theory, we could want to copy less things than those that were
-- built, but instead, we simply copy the targets that were built.
@@ -315,7 +343,7 @@ buildAndRegisterUnpackedPackage
flip filterTestFlags v $
setupHsTestFlags
pkg
- commonFlags
+ (commonFlags $ testArgs v)
testArgs _ = setupHsTestArgs pkg
benchCommand = Cabal.benchmarkCommand
@@ -324,7 +352,7 @@ buildAndRegisterUnpackedPackage
setupHsBenchFlags
pkg
pkgshared
- commonFlags
+ (commonFlags $ benchArgs v)
benchArgs _ = setupHsBenchArgs pkg
replCommand = Cabal.replCommand defaultProgramDb
@@ -333,7 +361,7 @@ buildAndRegisterUnpackedPackage
setupHsReplFlags
pkg
pkgshared
- commonFlags
+ (commonFlags $ replArgs v)
replArgs _ = setupHsReplArgs pkg
haddockCommand = Cabal.haddockCommand
@@ -343,7 +371,7 @@ buildAndRegisterUnpackedPackage
pkg
pkgshared
buildTimeSettings
- commonFlags
+ (commonFlags $ haddockArgs v)
haddockArgs v =
flip filterHaddockArgs v $
setupHsHaddockArgs pkg
@@ -356,17 +384,18 @@ buildAndRegisterUnpackedPackage
distDirLayout
srcdir
builddir
- (isParallelBuild buildSettingNumJobs)
cacheLock
setup
- :: CommandUI flags
+ :: (HasCallStack, RightFlagsForPhase flags setupSpec)
+ => CommandUI flags
-> (flags -> CommonSetupFlags)
-> (Version -> IO flags)
-> (Version -> [String])
- -> IO ()
- setup cmd getCommonFlags flags args =
- withLogging $ \mLogFileHandle -> do
+ -> SetupRunnerArgs setupSpec
+ -> IO (SetupRunnerRes setupSpec)
+ setup cmd getCommonFlags flags args wrapperArgs =
+ withLogging $ \mLogFileHandle ->
setupWrapper
(setVerbosityHandles mLogFileHandle verbosity)
scriptOptions
@@ -381,25 +410,24 @@ buildAndRegisterUnpackedPackage
getCommonFlags
flags
args
+ wrapperArgs
setupInteractive
- :: CommandUI flags
+ :: RightFlagsForPhase flags setupSpec
+ => CommandUI flags
-> (flags -> CommonSetupFlags)
- -> (Version -> flags)
+ -> (Version -> IO flags)
-> (Version -> [String])
- -> IO ()
- setupInteractive cmd getCommonFlags flags args =
+ -> SetupRunnerArgs setupSpec
+ -> IO (SetupRunnerRes setupSpec)
+ setupInteractive =
setupWrapper
verbosity
scriptOptions{isInteractive = True}
(Just (elabPkgDescription pkg))
- cmd
- getCommonFlags
- (\v -> return (flags v))
- args
- generateInstalledPackageInfo :: IO InstalledPackageInfo
- generateInstalledPackageInfo =
+ generateInstalledPackageInfo :: InLibraryLBI -> IO InstalledPackageInfo
+ generateInstalledPackageInfo mbLBI =
withTempInstalledPackageInfoFile
verbosity
distTempDirectory
@@ -409,9 +437,14 @@ buildAndRegisterUnpackedPackage
setupHsRegisterFlags
pkg
pkgshared
- commonFlags
+ (commonFlags [])
pkgConfDest
- setup (Cabal.registerCommand) Cabal.registerCommonFlags (\v -> return (registerFlags v)) (const [])
+ setup
+ (Cabal.registerCommand)
+ Cabal.registerCommonFlags
+ (return . registerFlags)
+ (const [])
+ (InLibraryArgs $ InLibraryPostConfigureArgs SRegisterPhase mbLBI)
withLogging :: (Maybe Handle -> IO r) -> IO r
withLogging action =
@@ -450,7 +483,7 @@ buildInplaceUnpackedPackage
buildSettings@BuildTimeSettings{buildSettingHaddockOpen}
registerLock
cacheLock
- pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os}
+ pkgshared
plan
rpkg@(ReadyPackage pkg)
buildStatus
@@ -465,12 +498,6 @@ buildInplaceUnpackedPackage
True
(distPackageCacheDirectory dparams)
- let docsResult = DocsNotTried
- testsResult = TestsNotTried
-
- buildResult :: BuildResultMisc
- buildResult = (docsResult, testsResult)
-
buildAndRegisterUnpackedPackage
verbosity
distDirLayout
@@ -485,65 +512,18 @@ buildInplaceUnpackedPackage
builddir
Nothing -- no log file for inplace builds!
$ \case
- PBConfigurePhase{runConfigure} -> do
- whenReConfigure $ do
- runConfigure
+ PBConfigurePhase{runConfigure} ->
+ whenReconfigure $ do
+ mbLBI <- runConfigure
invalidatePackageRegFileMonitor packageFileMonitor
updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg
- PBBuildPhase{runBuild} -> do
- whenRebuild $ do
- timestamp <- beginUpdateFileMonitor
- runBuild
- -- Be sure to invalidate the cache if building throws an exception!
- -- If not, we'll abort execution with a stale recompilation cache.
- -- See ghc#24926 for an example of how this can go wrong.
- `onException` invalidatePackageRegFileMonitor packageFileMonitor
-
- let listSimple =
- execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg)
- listSdist =
- fmap (map monitorFileHashed) $
- allPackageSourceFiles verbosity (getSymbolicPath srcdir)
- ifNullThen m m' = do
- xs <- m
- if null xs then m' else return xs
- monitors <- case PD.buildType (elabPkgDescription pkg) of
- Simple -> listSimple
- -- If a Custom setup was used, AND the Cabal is recent
- -- enough to have sdist --list-sources, use that to
- -- determine the files that we need to track. This can
- -- cause unnecessary rebuilding (for example, if README
- -- is edited, we will try to rebuild) but there isn't
- -- a more accurate Custom interface we can use to get
- -- this info. We prefer not to use listSimple here
- -- as it can miss extra source files that are considered
- -- by the Custom setup.
- _
- | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->
- -- However, sometimes sdist --list-sources will fail
- -- and return an empty list. In that case, fall
- -- back on the (inaccurate) simple tracking.
- listSdist `ifNullThen` listSimple
- | otherwise ->
- listSimple
-
- let dep_monitors =
- map monitorFileHashed $
- elabInplaceDependencyBuildCacheFiles
- distDirLayout
- pkgshared
- plan
- pkg
- updatePackageBuildFileMonitor
- packageFileMonitor
- (getSymbolicPath srcdir)
- timestamp
- pkg
- buildStatus
- (monitors ++ dep_monitors)
- buildResult
+ return mbLBI
+ PBBuildPhase{runBuild} ->
+ whenRebuild $ withFileMonitor runBuild
+ PBReplPhase{runRepl} ->
+ withFileMonitor runRepl
PBHaddockPhase{runHaddock} -> do
- runHaddock
+ withFileMonitor runHaddock
let haddockTarget = elabHaddockForHackage pkg
when (haddockTarget == Cabal.ForHackage) $ do
let dest = distDirectory name <.> "tar.gz"
@@ -586,7 +566,6 @@ buildInplaceUnpackedPackage
updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg
PBTestPhase{runTest} -> runTest
PBBenchPhase{runBench} -> runBench
- PBReplPhase{runRepl} -> runRepl
return
BuildResult
@@ -595,14 +574,78 @@ buildInplaceUnpackedPackage
, buildResultLogFile = Nothing
}
where
+ docsResult = DocsNotTried
+ testsResult = TestsNotTried
+ buildResult :: BuildResultMisc
+ buildResult = (docsResult, testsResult)
+
dparams = elabDistDirParams pkgshared pkg
- packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
+ Toolchain{toolchainPlatform = Platform _ os} =
+ getStage (pkgConfigToolchains pkgshared) (elabStage pkg)
- whenReConfigure action = case buildStatus of
- BuildStatusConfigure _ -> action
- _ -> return ()
+ packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
+ withFileMonitor :: IO [MonitorFilePath] -> IO ()
+ withFileMonitor runAction = do
+ timestamp <- beginUpdateFileMonitor
+ monitors' <-
+ runAction
+ -- Be sure to invalidate the cache if building throws an exception!
+ -- If not, we'll abort execution with a stale recompilation cache.
+ -- See ghc#24926 for an example of how this can go wrong.
+ `onException` invalidatePackageRegFileMonitor packageFileMonitor
+ let listSimple =
+ execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg)
+ listSdist =
+ fmap (map monitorFileHashed) $
+ allPackageSourceFiles verbosity (getSymbolicPath srcdir)
+ ifNullThen m m' = do
+ xs <- m
+ if null xs then m' else return xs
+ monitors <- case PD.buildType (elabPkgDescription pkg) of
+ Simple -> listSimple
+ Hooks -> listSdist `ifNullThen` listSimple
+ _
+ | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->
+ listSdist `ifNullThen` listSimple
+ | otherwise ->
+ listSimple
+
+ let dep_monitors =
+ map monitorFileHashed $
+ elabInplaceDependencyBuildCacheFiles
+ distDirLayout
+ pkgshared
+ plan
+ pkg
+ updatePackageBuildFileMonitor
+ packageFileMonitor
+ (getSymbolicPath srcdir)
+ timestamp
+ pkg
+ buildStatus
+ (monitors ++ monitors' ++ dep_monitors)
+ buildResult
+
+ whenReconfigure :: IO InLibraryLBI -> IO InLibraryLBI
+ whenReconfigure action =
+ case buildStatus of
+ BuildStatusConfigure _ -> action
+ _ -> do
+ lbi_wo_programs <- Cabal.getPersistBuildConfig (Just srcdir) builddir
+ -- Restore info about unconfigured programs, since it is not serialized
+ -- TODO: copied from Distribution.Simple.getBuildConfig.
+ let lbi =
+ lbi_wo_programs
+ { Cabal.withPrograms =
+ restoreProgramDb
+ builtinPrograms
+ (Cabal.withPrograms lbi_wo_programs)
+ }
+ return $ InLibraryLBI lbi
+
+ whenRebuild, whenReRegister :: IO () -> IO ()
whenRebuild action
| null (elabBuildTargets pkg)
, -- NB: we have to build the test/bench suite!
@@ -655,10 +698,7 @@ buildAndInstallUnpackedPackage
buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile}
registerLock
cacheLock
- pkgshared@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigPlatform = platform
- }
+ pkgshared
plan
rpkg@(ReadyPackage pkg)
srcdir
@@ -697,10 +737,12 @@ buildAndInstallUnpackedPackage
runConfigure
PBBuildPhase{runBuild} -> do
noticeProgress ProgressBuilding
- runBuild
+ _monitors <- runBuild
+ return ()
PBHaddockPhase{runHaddock} -> do
noticeProgress ProgressHaddock
- runHaddock
+ _monitors <- runHaddock
+ return ()
PBInstallPhase{runCopy, runRegister} -> do
noticeProgress ProgressInstalling
@@ -710,11 +752,8 @@ buildAndInstallUnpackedPackage
"registerPkg: elab does NOT require registration for "
++ prettyShow uid
| otherwise = do
- assert
- ( elabRegisterPackageDBStack pkg
- == storePackageDBStack compiler (elabPackageDbs pkg)
- )
- (return ())
+ let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout toolchainCompiler]
+ assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ())
_ <-
runRegister
(elabRegisterPackageDBStack pkg)
@@ -729,7 +768,7 @@ buildAndInstallUnpackedPackage
newStoreEntry
verbosity
storeDirLayout
- compiler
+ toolchainCompiler
uid
(copyPkgFiles verbosity pkgshared pkg runCopy)
registerPkg
@@ -767,6 +806,9 @@ buildAndInstallUnpackedPackage
uid = installedUnitId rpkg
pkgid = packageId rpkg
+ Toolchain{toolchainCompiler, toolchainPlatform} =
+ getStage (pkgConfigToolchains pkgshared) (elabStage pkg)
+
dispname :: String
dispname = case elabPkgOrComp pkg of
-- Packages built altogether, instead of per component
@@ -791,7 +833,7 @@ buildAndInstallUnpackedPackage
mlogFile =
case buildSettingLogFile of
Nothing -> Nothing
- Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
+ Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid)
initLogFile :: IO ()
initLogFile =
@@ -799,8 +841,7 @@ buildAndInstallUnpackedPackage
Nothing -> return ()
Just logFile -> do
createDirectoryIfMissing True (takeDirectory logFile)
- exists <- doesFileExist logFile
- when exists $ removeFile logFile
+ removeFileForcibly logFile
-- | The copy part of the installation phase when doing build-and-install
copyPkgFiles
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
index a00d0c82242..a96fa4a0926 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -14,6 +14,7 @@ module Distribution.Client.ProjectConfig
, ProjectConfigBuildOnly (..)
, ProjectConfigShared (..)
, ProjectConfigSkeleton
+ , ProjectConfigToolchain (..)
, ProjectConfigProvenance (..)
, PackageConfig (..)
, MapLast (..)
@@ -612,8 +613,7 @@ findProjectRoot verbosity mprojectDir mprojectFile = do
getProjectRootUsability file >>= \case
ProjectRootUsabilityPresentAndUsable ->
- uncurry projectRoot
- =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file
+ uncurry projectRoot . first dropTrailingPathSeparator . splitFileName =<< canonicalizePath file
ProjectRootUsabilityNotPresent ->
left (BadProjectRootExplicitFileNotFound file)
ProjectRootUsabilityPresentAndUnusable ->
@@ -1281,28 +1281,29 @@ findProjectPackages
checkIsFileGlobPackage pkglocstr =
case simpleParsec pkglocstr of
Nothing -> return Nothing
- Just glob -> liftM Just $ do
- matches <- matchFileGlob glob
- case matches of
- []
- | isJust (isTrivialRootedGlob glob) ->
- return
- ( Left
- ( BadPackageLocationFile
- (BadLocNonexistentFile pkglocstr)
- )
- )
- [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))
- _ -> do
- (failures, pkglocs) <-
- partitionEithers
- <$> traverse checkFilePackageMatch matches
- return $! case (failures, pkglocs) of
- ([failure], [])
- | isJust (isTrivialRootedGlob glob) ->
- Left (BadPackageLocationFile failure)
- (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
- _ -> Right pkglocs
+ Just glob ->
+ Just <$> do
+ matches <- matchFileGlob glob
+ case matches of
+ []
+ | isJust (isTrivialRootedGlob glob) ->
+ return
+ ( Left
+ ( BadPackageLocationFile
+ (BadLocNonexistentFile pkglocstr)
+ )
+ )
+ [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))
+ _ -> do
+ (failures, pkglocs) <-
+ partitionEithers
+ <$> traverse checkFilePackageMatch matches
+ return $! case (failures, pkglocs) of
+ ([failure], [])
+ | isJust (isTrivialRootedGlob glob) ->
+ Left (BadPackageLocationFile failure)
+ (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
+ _ -> Right pkglocs
checkIsSingleFilePackage pkglocstr = do
let filename = distProjectRootDirectory pkglocstr
@@ -1400,7 +1401,6 @@ mplusMaybeT ma mb = do
fetchAndReadSourcePackages
:: Verbosity
-> DistDirLayout
- -> Maybe Compiler
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> [ProjectPackageLocation]
@@ -1408,7 +1408,6 @@ fetchAndReadSourcePackages
fetchAndReadSourcePackages
verbosity
distDirLayout
- compiler
projectConfigShared
projectConfigBuildOnly
pkgLocations = do
@@ -1445,7 +1444,6 @@ fetchAndReadSourcePackages
syncAndReadSourcePackagesRemoteRepos
verbosity
distDirLayout
- compiler
projectConfigShared
projectConfigBuildOnly
(fromFlag (projectConfigOfflineMode projectConfigBuildOnly))
@@ -1565,7 +1563,6 @@ fetchAndReadSourcePackageRemoteTarball
syncAndReadSourcePackagesRemoteRepos
:: Verbosity
-> DistDirLayout
- -> Maybe Compiler
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> Bool
@@ -1574,7 +1571,6 @@ syncAndReadSourcePackagesRemoteRepos
syncAndReadSourcePackagesRemoteRepos
verbosity
DistDirLayout{distDownloadSrcDirectory}
- compiler
ProjectConfigShared
{ projectConfigProgPathExtra
}
@@ -1609,7 +1605,7 @@ syncAndReadSourcePackagesRemoteRepos
concat
<$> rerunConcurrentlyIfChanged
verbosity
- (newJobControlFromParStrat verbosity compiler parStrat (Just maxNumFetchJobs))
+ (newJobControlFromParStrat verbosity parStrat (Just maxNumFetchJobs))
[ ( monitor
, repoGroup'
, do
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
index f49279f7781..1422900fdd0 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
@@ -12,7 +12,14 @@ import qualified Data.Set as Set
import Distribution.CabalSpecVersion (CabalSpecVersion (..))
import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGrammar)
import qualified Distribution.Client.ProjectConfig.Lens as L
-import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..))
+import Distribution.Client.ProjectConfig.Types
+ ( PackageConfig (..)
+ , ProjectConfig (..)
+ , ProjectConfigBuildOnly (..)
+ , ProjectConfigProvenance (..)
+ , ProjectConfigShared (..)
+ , ProjectConfigToolchain (..)
+ )
import Distribution.Client.Utils.Parsec
import Distribution.Compat.Prelude
import Distribution.FieldGrammar
@@ -76,12 +83,9 @@ projectConfigSharedFieldGrammar source =
<*> optionalFieldDefAla "project-file" (alaFlag FilePathNT) L.projectConfigProjectFile mempty
<*> pure mempty -- You can't set the parser type in the project file.
<*> optionalFieldDef "ignore-project" L.projectConfigIgnoreProject mempty
- <*> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty
- <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty
- <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty
+ <*> blurFieldGrammar L.projectConfigToolchain projectConfigToolchainFieldGrammar
<*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty
<*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar
- <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs
<*> pure mempty -- repository stanza for projectConfigRemoteRepos
<*> pure mempty -- repository stanza for projectConfigLocalNoIndexRepos
<*> monoidalField "active-repositories" L.projectConfigActiveRepos
@@ -109,6 +113,18 @@ projectConfigSharedFieldGrammar source =
<*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra
<*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty
+projectConfigToolchainFieldGrammar :: ParsecFieldGrammar' ProjectConfigToolchain
+projectConfigToolchainFieldGrammar =
+ ProjectConfigToolchain
+ <$> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty
+ <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty
+ <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty
+ <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs
+ <*> optionalFieldDef "build-compiler" L.projectConfigBuildHcFlavor mempty
+ <*> optionalFieldDefAla "with-build-compiler" (alaFlag FilePathNT) L.projectConfigBuildHcPath mempty
+ <*> optionalFieldDefAla "with-build-hc-pkg" (alaFlag FilePathNT) L.projectConfigBuildHcPkg mempty
+ <*> monoidalFieldAla "build-package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigBuildPackageDBs
+
packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig
packageConfigFieldGrammar knownPrograms =
mkPackageConfig
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
index bc1e1fb8d2c..e8f77515616 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -140,7 +139,8 @@ import Distribution.Types.CondTree
, CondTree (..)
, ignoreConditions
, mapTreeConds
- , traverseCondTreeC
+ , mapTreeData
+ , traverseCondTreeA
, traverseCondTreeV
)
import Distribution.Types.SourceRepo (RepoType)
@@ -216,14 +216,14 @@ import qualified Text.PrettyPrint as Disp
-- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping a config. It can be finalized by providing the conditional resolution info
-- and then resolving and downloading the imports
-type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigPath] ProjectConfig
+type ProjectConfigSkeleton = CondTree ConfVar ([ProjectConfigPath], ProjectConfig)
singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
-singletonProjectConfigSkeleton x = CondNode x mempty mempty
+singletonProjectConfigSkeleton x = CondNode (mempty, x) mempty
instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, Compiler) -> FlagAssignment -> ProjectConfigSkeleton -> m (ProjectConfig, Maybe Compiler)
instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
- | null (toListOf traverseCondTreeV skel) = pure (fst (ignoreConditions skel), Nothing)
+ | null (toListOf traverseCondTreeV skel) = pure (ignoreConditions $ mapTreeData snd skel, Nothing)
| otherwise = do
(os, arch, comp) <- fetch
let conf = instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo comp) flags skel
@@ -232,13 +232,8 @@ instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel
where
- go
- :: CondTree
- FlagName
- [ProjectConfigPath]
- ProjectConfig
- -> ProjectConfig
- go (CondNode l _imps ts) =
+ go :: CondTree FlagName ([ProjectConfigPath], ProjectConfig) -> ProjectConfig
+ go (CondNode (_, l) ts) =
let branches = concatMap processBranch ts
in l <> mconcat branches
processBranch (CondBranch cnd t mf) = case cnd of
@@ -247,7 +242,7 @@ instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ map
_ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer
projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigPath]
-projectSkeletonImports = view traverseCondTreeC
+projectSkeletonImports = fst . view traverseCondTreeA
-- | Parses a project from its root config file, typically cabal.project.
parseProject
@@ -298,7 +293,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
when
(isUntrimmedUriConfigPath importLocPath)
(noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)
- let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)
+ let fs = (\z -> CondNode ([normLocPath], z) mempty) <$> fieldsToConfig normSource (reverse acc)
res <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
rest <- go [] xs
pure . fmap mconcat . sequence $ [projectParse Nothing normSource fs, res, rest]
@@ -308,7 +303,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
let fs = singletonProjectConfigSkeleton <$> fieldsToConfig source (reverse acc)
(elseClauses, rest) <- parseElseClauses xs
let condNode =
- (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
+ (\c pcs e -> CondNode mempty [CondBranch c pcs e])
<$>
-- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused
( let s = "if(" <> p <> ")"
@@ -333,7 +328,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
subpcs <- go [] xs'
(elseClauses, rest) <- parseElseClauses xs
let condNode =
- (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
+ (\c pcs e -> CondNode mempty [CondBranch c pcs e])
<$> ( let s = "elif(" <> p <> ")"
in projectParse (Just s) normSource (adaptParseError l (parseConditionConfVarFromClause $ BS.pack s))
)
@@ -385,16 +380,16 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
modifiesCompiler :: ProjectConfig -> Bool
modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg
where
- isSet f = f (projectConfigShared pc) /= NoFlag
+ isSet f = f (projectConfigToolchain $ projectConfigShared pc) /= NoFlag
sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ProjectParseResult ProjectConfigSkeleton
- sanityWalkPCS underConditional t@(CondNode d (listToMaybe -> c) comps)
+ sanityWalkPCS underConditional t@(CondNode (listToMaybe -> c, d) comps)
| underConditional && modifiesCompiler d =
projectParseFail Nothing c $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing
| otherwise =
mapM_ sanityWalkBranch comps >> pure t
- sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ProjectParseResult ()
+ sanityWalkBranch :: CondBranch ConfVar ([ProjectConfigPath], ProjectConfig) -> ProjectParseResult ()
sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()
------------------------------------------------------------------
@@ -716,17 +711,17 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
, globalStoreDir = projectConfigStoreDir
} = globalFlags
+ projectConfigToolchain = ProjectConfigToolchain{..}
projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_
+ projectConfigBuildPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigBuildPackageDBs_
ConfigFlags
{ configCommonFlags = commonFlags
, configHcFlavor = projectConfigHcFlavor
, configHcPath = projectConfigHcPath
, configHcPkg = projectConfigHcPkg
- , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME
- configInstallDirs = projectConfigInstallDirs
- , -- configUserInstall = projectConfigUserInstall,
- configPackageDBs = projectConfigPackageDBs_
+ , configInstallDirs = projectConfigInstallDirs
+ , configPackageDBs = projectConfigPackageDBs_
} = configFlags
CommonSetupFlags
@@ -744,6 +739,10 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
, configAllowNewer = projectConfigAllowNewer
, configWriteGhcEnvironmentFilesPolicy =
projectConfigWriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor = projectConfigBuildHcFlavor
+ , configBuildHcPath = projectConfigBuildHcPath
+ , configBuildHcPkg = projectConfigBuildHcPkg
+ , configBuildPackageDBs = projectConfigBuildPackageDBs_
} = configExFlags
InstallFlags
@@ -967,10 +966,7 @@ convertToLegacySharedConfig
ProjectConfig
{ projectConfigBuildOnly = ProjectConfigBuildOnly{..}
, projectConfigShared = ProjectConfigShared{..}
- , projectConfigAllPackages =
- PackageConfig
- { packageConfigDocumentation
- }
+ , projectConfigAllPackages = PackageConfig{..}
} =
LegacySharedConfig
{ legacyGlobalFlags = globalFlags
@@ -982,6 +978,7 @@ convertToLegacySharedConfig
, legacyMultiRepl = projectConfigMultiRepl
}
where
+ ProjectConfigToolchain{..} = projectConfigToolchain
globalFlags =
GlobalFlags
{ globalVersion = mempty
@@ -1026,6 +1023,10 @@ convertToLegacySharedConfig
, configAllowNewer = projectConfigAllowNewer
, configWriteGhcEnvironmentFilesPolicy =
projectConfigWriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor = projectConfigBuildHcFlavor
+ , configBuildHcPath = projectConfigBuildHcPath
+ , configBuildHcPkg = projectConfigBuildHcPkg
+ , configBuildPackageDBs = fmap (fmap (fmap unsafeMakeSymbolicPath)) projectConfigBuildPackageDBs
}
installFlags =
@@ -1088,6 +1089,8 @@ convertToLegacyAllPackageConfig
, legacyBenchmarkFlags = mempty
}
where
+ ProjectConfigToolchain{..} = projectConfigToolchain
+
commonFlags =
mempty
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs
index 03164305a62..fcbdbcbae88 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs
@@ -7,7 +7,16 @@ import Distribution.Client.IndexUtils.ActiveRepos
( ActiveRepos
)
import Distribution.Client.IndexUtils.IndexState (TotalIndexState)
-import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared)
+import Distribution.Client.ProjectConfig.Types
+ ( MapLast
+ , MapMappend
+ , PackageConfig
+ , ProjectConfig (..)
+ , ProjectConfigBuildOnly (..)
+ , ProjectConfigProvenance
+ , ProjectConfigShared
+ , ProjectConfigToolchain (..)
+ )
import qualified Distribution.Client.ProjectConfig.Types as T
import Distribution.Client.Targets (UserConstraint)
import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder)
@@ -192,18 +201,42 @@ projectConfigIgnoreProject :: Lens' ProjectConfigShared (Flag Bool)
projectConfigIgnoreProject f s = fmap (\x -> s{T.projectConfigIgnoreProject = x}) (f (T.projectConfigIgnoreProject s))
{-# INLINEABLE projectConfigIgnoreProject #-}
-projectConfigHcFlavor :: Lens' ProjectConfigShared (Flag CompilerFlavor)
+projectConfigToolchain :: Lens' ProjectConfigShared ProjectConfigToolchain
+projectConfigToolchain f s = fmap (\x -> s{T.projectConfigToolchain = x}) (f (T.projectConfigToolchain s))
+{-# INLINEABLE projectConfigToolchain #-}
+
+projectConfigHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor)
projectConfigHcFlavor f s = fmap (\x -> s{T.projectConfigHcFlavor = x}) (f (T.projectConfigHcFlavor s))
{-# INLINEABLE projectConfigHcFlavor #-}
-projectConfigHcPath :: Lens' ProjectConfigShared (Flag FilePath)
+projectConfigHcPath :: Lens' ProjectConfigToolchain (Flag FilePath)
projectConfigHcPath f s = fmap (\x -> s{T.projectConfigHcPath = x}) (f (T.projectConfigHcPath s))
{-# INLINEABLE projectConfigHcPath #-}
-projectConfigHcPkg :: Lens' ProjectConfigShared (Flag FilePath)
+projectConfigHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath)
projectConfigHcPkg f s = fmap (\x -> s{T.projectConfigHcPkg = x}) (f (T.projectConfigHcPkg s))
{-# INLINEABLE projectConfigHcPkg #-}
+projectConfigPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD]
+projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s))
+{-# INLINEABLE projectConfigPackageDBs #-}
+
+projectConfigBuildHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor)
+projectConfigBuildHcFlavor f s = fmap (\x -> s{T.projectConfigBuildHcFlavor = x}) (f (T.projectConfigBuildHcFlavor s))
+{-# INLINEABLE projectConfigBuildHcFlavor #-}
+
+projectConfigBuildHcPath :: Lens' ProjectConfigToolchain (Flag FilePath)
+projectConfigBuildHcPath f s = fmap (\x -> s{T.projectConfigBuildHcPath = x}) (f (T.projectConfigBuildHcPath s))
+{-# INLINEABLE projectConfigBuildHcPath #-}
+
+projectConfigBuildHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath)
+projectConfigBuildHcPkg f s = fmap (\x -> s{T.projectConfigBuildHcPkg = x}) (f (T.projectConfigBuildHcPkg s))
+{-# INLINEABLE projectConfigBuildHcPkg #-}
+
+projectConfigBuildPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD]
+projectConfigBuildPackageDBs f s = fmap (\x -> s{T.projectConfigBuildPackageDBs = x}) (f (T.projectConfigBuildPackageDBs s))
+{-# INLINEABLE projectConfigBuildPackageDBs #-}
+
projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate)
projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s))
{-# INLINEABLE projectConfigHaddockIndex #-}
@@ -212,10 +245,6 @@ projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTem
projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s))
{-# INLINEABLE projectConfigInstallDirs #-}
-projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDBCWD]
-projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s))
-{-# INLINEABLE projectConfigPackageDBs #-}
-
projectConfigLocalNoIndexRepos :: Lens' ProjectConfigShared (NubList LocalRepo)
projectConfigLocalNoIndexRepos f s = fmap (\x -> s{T.projectConfigLocalNoIndexRepos = x}) (f (T.projectConfigLocalNoIndexRepos s))
{-# INLINEABLE projectConfigLocalNoIndexRepos #-}
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
index 06d9631e5f3..0576186de29 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
@@ -66,7 +66,7 @@ import Text.PrettyPrint (render)
import qualified Text.PrettyPrint as Disp
singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
-singletonProjectConfigSkeleton x = CondNode x mempty mempty
+singletonProjectConfigSkeleton x = CondNode (mempty, x) mempty
readPreprocessFields :: BS.ByteString -> ParseResult src [Field Position]
readPreprocessFields bs = do
@@ -136,7 +136,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
when
(isUntrimmedUriConfigPath importLocPath)
(noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)
- let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc)
+ let fs = (\z -> CondNode ([normLocPath], z) mempty) <$> fieldsToConfig normSource (reverse acc)
importParseResult <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath
rest <- go [] xs
@@ -148,7 +148,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig source (reverse acc)
(elseClauses, rest) <- parseElseClauses xs
let condNode =
- (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
+ (\c pcs e -> CondNode mempty [CondBranch c pcs e])
<$> parseConditionConfVar (startOfSection (incPos 2 pos) args) args
<*> subpcs
<*> elseClauses
@@ -168,7 +168,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
subpcs <- go [] xs'
(elseClauses, rest) <- parseElseClauses xs
let condNode =
- (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
+ (\c pcs e -> CondNode mempty [CondBranch c pcs e])
<$> parseConditionConfVar (startOfSection (incPos 4 pos) args) args
<*> subpcs
<*> elseClauses
@@ -210,14 +210,14 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project
modifiesCompiler :: ProjectConfig -> Bool
modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg
where
- isSet f = f (projectConfigShared pc) /= NoFlag
+ isSet f = f (projectConfigToolchain (projectConfigShared pc)) /= NoFlag
sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectFileSource ProjectConfigSkeleton
- sanityWalkPCS underConditional t@(CondNode d _c comps)
+ sanityWalkPCS underConditional t@(CondNode (_c, d) comps)
| underConditional && modifiesCompiler d = parseFatalFailure zeroPos "Cannot set compiler in a conditional clause of a cabal project file"
| otherwise = mapM_ sanityWalkBranch comps >> pure t
- sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ParseResult ProjectFileSource ()
+ sanityWalkBranch :: CondBranch ConfVar ([ProjectConfigPath], ProjectConfig) -> ParseResult ProjectFileSource ()
sanityWalkBranch (CondBranch _c t f) = traverse_ (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()
programDb = defaultProgramDb
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
index 751875be403..e2c36da813f 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -9,6 +9,7 @@ module Distribution.Client.ProjectConfig.Types
, ProjectConfigToParse (..)
, ProjectConfigBuildOnly (..)
, ProjectConfigShared (..)
+ , ProjectConfigToolchain (..)
, ProjectConfigProvenance (..)
, PackageConfig (..)
, ProjectFileParser (..)
@@ -194,16 +195,13 @@ data ProjectConfigShared = ProjectConfigShared
, projectConfigProjectFile :: Flag FilePath
, projectConfigProjectFileParser :: Flag ProjectFileParser
, projectConfigIgnoreProject :: Flag Bool
- , projectConfigHcFlavor :: Flag CompilerFlavor
- , projectConfigHcPath :: Flag FilePath
- , projectConfigHcPkg :: Flag FilePath
+ , projectConfigToolchain :: ProjectConfigToolchain
, projectConfigHaddockIndex :: Flag PathTemplate
, -- Only makes sense for manual mode, not --local mode
-- too much control!
-- projectConfigUserInstall :: Flag Bool,
projectConfigInstallDirs :: InstallDirs (Flag PathTemplate)
- , projectConfigPackageDBs :: [Maybe PackageDBCWD]
, -- configuration used both by the solver and other phases
projectConfigRemoteRepos :: NubList RemoteRepo
-- ^ Available Hackage servers.
@@ -243,6 +241,18 @@ data ProjectConfigShared = ProjectConfigShared
}
deriving (Eq, Show, Generic)
+data ProjectConfigToolchain = ProjectConfigToolchain
+ { projectConfigHcFlavor :: Flag CompilerFlavor
+ , projectConfigHcPath :: Flag FilePath
+ , projectConfigHcPkg :: Flag FilePath
+ , projectConfigPackageDBs :: [Maybe PackageDBCWD]
+ , projectConfigBuildHcFlavor :: Flag CompilerFlavor
+ , projectConfigBuildHcPath :: Flag FilePath
+ , projectConfigBuildHcPkg :: Flag FilePath
+ , projectConfigBuildPackageDBs :: [Maybe PackageDBCWD]
+ }
+ deriving (Eq, Show, Generic)
+
data ProjectFileParser
= LegacyParser
| ParsecParser
@@ -347,6 +357,7 @@ data PackageConfig = PackageConfig
instance Binary ProjectConfig
instance Binary ProjectConfigBuildOnly
+instance Binary ProjectConfigToolchain
instance Binary ProjectConfigShared
instance Binary ProjectConfigProvenance
instance Binary PackageConfig
@@ -354,6 +365,7 @@ instance Binary ProjectFileParser
instance Structured ProjectConfig
instance Structured ProjectConfigBuildOnly
+instance Structured ProjectConfigToolchain
instance Structured ProjectConfigShared
instance Structured ProjectConfigProvenance
instance Structured PackageConfig
@@ -364,6 +376,7 @@ instance NFData ProjectConfigToParse where
instance NFData ProjectConfig
instance NFData ProjectConfigBuildOnly
+instance NFData ProjectConfigToolchain
instance NFData ProjectConfigShared
instance NFData ProjectConfigProvenance where
@@ -422,6 +435,13 @@ instance Monoid ProjectConfigBuildOnly where
instance Semigroup ProjectConfigBuildOnly where
(<>) = gmappend
+instance Monoid ProjectConfigToolchain where
+ mempty = gmempty
+ mappend = (<>)
+
+instance Semigroup ProjectConfigToolchain where
+ (<>) = gmappend
+
instance Monoid ProjectConfigShared where
mempty = gmempty
mappend = (<>)
diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
index 3538ac71260..5baeb8b8346 100644
--- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
+++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@@ -61,6 +62,7 @@ module Distribution.Client.ProjectOrchestration
, resolveTargetsFromSolver
, resolveTargetsFromLocalPackages
, TargetsMap
+ , TargetsMapS
, allTargetSelectors
, uniqueTargetSelectors
, TargetSelector (..)
@@ -102,12 +104,14 @@ module Distribution.Client.ProjectOrchestration
-- * Dummy projects
, establishDummyProjectBaseContext
, establishDummyDistDirLayout
+ , filterTargetsWithStage
) where
import Distribution.Client.Compat.Prelude
import System.Directory
( makeAbsolute
)
+import qualified Distribution.Compat.Graph as Graph
import Prelude ()
import Distribution.Client.ProjectBuilding
@@ -135,12 +139,9 @@ import Distribution.Client.TargetSelector
, reportTargetSelectorProblems
)
import Distribution.Client.Types
- ( DocsResult (..)
- , GenericReadyPackage (..)
- , PackageLocation (..)
+ ( GenericReadyPackage (..)
, PackageSpecifier (..)
, SourcePackageDb (..)
- , TestsResult (..)
, UnresolvedSourcePackage
, WriteGhcEnvironmentFilesPolicy (..)
)
@@ -149,23 +150,11 @@ import Distribution.Solver.Types.PackageIndex
)
import Distribution.Solver.Types.SourcePackage (SourcePackage (..))
-import Distribution.Client.BuildReports.Anonymous (cabalInstallID)
-import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
-import qualified Distribution.Client.BuildReports.Storage as BuildReports
- ( storeLocal
- )
-
import Distribution.Client.HttpUtils
import Distribution.Client.Setup hiding (packageName)
-import Distribution.Compiler
- ( CompilerFlavor (GHC)
- )
import Distribution.Types.ComponentName
( componentNameString
)
-import Distribution.Types.InstalledPackageInfo
- ( InstalledPackageInfo
- )
import Distribution.Types.UnqualComponentName
( UnqualComponentName
, packageNameToUnqualComponentName
@@ -184,9 +173,6 @@ import Distribution.Package
import Distribution.Simple.Command (commandShowOptions)
import Distribution.Simple.Compiler
( OptimisationLevel (..)
- , compilerCompatVersion
- , compilerId
- , compilerInfo
, showCompilerId
)
import Distribution.Simple.Configure (computeEffectiveProfiling)
@@ -209,22 +195,19 @@ import Distribution.Simple.Utils
, ordNub
, warn
)
-import Distribution.System
- ( Platform (Platform)
- )
import Distribution.Types.Flag
( FlagAssignment
, diffFlagAssignment
, showFlagAssignment
)
+import Distribution.Utils.LogProgress
+ ( LogProgress
+ )
import Distribution.Utils.NubList
( fromNubList
)
import Distribution.Utils.Path (makeSymbolicPath)
import Distribution.Verbosity
-import Distribution.Version
- ( mkVersion
- )
#ifdef MIN_VERSION_unix
import System.Posix.Signals (sigKILL, sigSEGV)
@@ -345,7 +328,7 @@ data ProjectBuildContext = ProjectBuildContext
, pkgsBuildStatus :: BuildStatusMap
-- ^ The result of the dry-run phase. This tells us about each member of
-- the 'elaboratedPlanToExecute'.
- , targetsMap :: TargetsMap
+ , targetsMap :: TargetsMapS
-- ^ The targets selected by @selectPlanSubset@. This is useful eg. in
-- CmdRun, where we need a valid target to execute.
}
@@ -383,7 +366,7 @@ withInstallPlan
runProjectPreBuildPhase
:: Verbosity
-> ProjectBaseContext
- -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
+ -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMapS))
-> IO ProjectBuildContext
runProjectPreBuildPhase
verbosity
@@ -490,7 +473,7 @@ runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _
runProjectPostBuildPhase
verbosity
ProjectBaseContext{..}
- bc@ProjectBuildContext{..}
+ ProjectBuildContext{..}
buildOutcomes = do
-- Update other build artefacts
-- TODO: currently none, but could include:
@@ -519,21 +502,19 @@ runProjectPostBuildPhase
writeGhcEnvFilesPolicy of
AlwaysWriteGhcEnvironmentFiles -> True
NeverWriteGhcEnvironmentFiles -> False
- WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->
- let compiler = pkgConfigCompiler elaboratedShared
- ghcCompatVersion = compilerCompatVersion GHC compiler
- in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion
-
+ -- FIXME: whatever
+ WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> True
when shouldWriteGhcEnvironment $
void $
writePlanGhcEnvironment
(distProjectRootDirectory distDirLayout)
+ Host
elaboratedPlanOriginal
elaboratedShared
postBuildStatus
-- Write the build reports
- writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes
+ -- writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes
-- Finally if there were any build failures then report them and throw
-- an exception to terminate the program
@@ -571,12 +552,22 @@ type TargetsMap = TargetsMapX UnitId
type TargetsMapX u = Map u [(ComponentTarget, NonEmpty TargetSelector)]
+type TargetsMapS = TargetsMapX (WithStage UnitId)
+
+filterTargetsWithStage :: Stage -> TargetsMapS -> TargetsMap
+filterTargetsWithStage stage =
+ Map.fromList
+ . mapMaybe (\(WithStage s uid, v) -> if s == stage then Just (uid, v) else Nothing)
+ . Map.toList
+
+-- Map.mapMaybeWithKey (\(WithStage s uid) v -> if s == stage then Just v else Nothing)
+
-- | Get all target selectors.
-allTargetSelectors :: TargetsMap -> [TargetSelector]
+allTargetSelectors :: TargetsMapS -> [TargetSelector]
allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems
-- | Get all unique target selectors.
-uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
+uniqueTargetSelectors :: TargetsMapS -> [TargetSelector]
uniqueTargetSelectors = ordNub . allTargetSelectors
-- | Resolve targets from a solver result.
@@ -599,7 +590,7 @@ resolveTargetsFromSolver
-> ElaboratedInstallPlan
-> Maybe (SourcePackageDb)
-> [TargetSelector]
- -> Either [TargetProblem err] TargetsMap
+ -> Either [TargetProblem err] TargetsMapS
resolveTargetsFromSolver selectPackageTargets selectComponentTarget installPlan sourceDb targetSelectors =
resolveTargets
selectPackageTargets
@@ -782,7 +773,7 @@ resolveTargets
-> [(b, ComponentName)]
-> [(b, ComponentTarget)]
componentTargets subtarget =
- map (fmap (\cname -> ComponentTarget cname subtarget))
+ map (fmap (`ComponentTarget` subtarget))
selectComponentTargets
:: SubComponentTarget
@@ -821,18 +812,18 @@ type AvailableTargetsMap k u = Map k [AvailableTarget (u, ComponentName)]
--
-- They are all constructed lazily because they are not necessarily all used.
--
-availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes UnitId
+availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes (WithStage UnitId)
availableTargetIndexes installPlan = AvailableTargetIndexes{..}
where
availableTargetsByPackageIdAndComponentName
:: Map
(PackageId, ComponentName)
- [AvailableTarget (UnitId, ComponentName)]
+ [AvailableTarget (WithStage UnitId, ComponentName)]
availableTargetsByPackageIdAndComponentName =
availableTargets installPlan
availableTargetsByPackageId
- :: Map PackageId [AvailableTarget (UnitId, ComponentName)]
+ :: Map PackageId [AvailableTarget (WithStage UnitId, ComponentName)]
availableTargetsByPackageId =
Map.mapKeysWith
(++)
@@ -841,7 +832,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..}
`Map.union` availableTargetsEmptyPackages
availableTargetsByPackageName
- :: Map PackageName [AvailableTarget (UnitId, ComponentName)]
+ :: Map PackageName [AvailableTarget (WithStage UnitId, ComponentName)]
availableTargetsByPackageName =
Map.mapKeysWith
(++)
@@ -851,7 +842,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..}
availableTargetsByPackageNameAndComponentName
:: Map
(PackageName, ComponentName)
- [AvailableTarget (UnitId, ComponentName)]
+ [AvailableTarget (WithStage UnitId, ComponentName)]
availableTargetsByPackageNameAndComponentName =
Map.mapKeysWith
(++)
@@ -861,7 +852,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..}
availableTargetsByPackageNameAndUnqualComponentName
:: Map
(PackageName, UnqualComponentName)
- [AvailableTarget (UnitId, ComponentName)]
+ [AvailableTarget (WithStage UnitId, ComponentName)]
availableTargetsByPackageNameAndUnqualComponentName =
Map.mapKeysWith
(++)
@@ -1053,9 +1044,9 @@ selectComponentTargetBasic
-- for the extra unneeded info in the 'TargetsMap'.
pruneInstallPlanToTargets
:: TargetAction
- -> TargetsMap
- -> ElaboratedInstallPlan
+ -> TargetsMapS
-> ElaboratedInstallPlan
+ -> LogProgress ElaboratedInstallPlan
pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =
assert (Map.size targetsMap > 0) $
ProjectPlanning.pruneInstallPlanToTargets
@@ -1065,7 +1056,7 @@ pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =
-- | Utility used by repl and run to check if the targets spans multiple
-- components, since those commands do not support multiple components.
-distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName)
+distinctTargetComponents :: TargetsMapS -> Set.Set (WithStage UnitId, ComponentName)
distinctTargetComponents targetsMap =
Set.fromList
[ (uid, cname)
@@ -1136,6 +1127,7 @@ printPlan
filter
(not . null)
[ " -"
+ , prettyShow (elabStage elab)
, if verbosityLevel verbosity >= Deafening
then prettyShow (installedUnitId elab)
else prettyShow (packageId elab)
@@ -1145,17 +1137,17 @@ printPlan
, case elabPkgOrComp elab of
ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg))
ElabComponent comp ->
- "(" ++ showComp elab comp ++ ")"
+ "(" ++ showComp comp ++ ")"
, showFlagAssignment (nonDefaultFlags elab)
, showConfigureFlags elab
- , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
+ , let buildStatus = pkgsBuildStatus Map.! Graph.nodeKey elab
in "(" ++ showBuildStatus buildStatus ++ ")"
]
- showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
- showComp elab comp =
+ showComp :: ElaboratedComponent -> String
+ showComp comp =
maybe "custom" prettyShow (compComponentName comp)
- ++ if Map.null (elabInstantiatedWith elab)
+ ++ if Map.null (compInstantiatedWith comp)
then ""
else
" with "
@@ -1163,7 +1155,7 @@ printPlan
", "
-- TODO: Abbreviate the UnitIds
[ prettyShow k ++ "=" ++ prettyShow v
- | (k, v) <- Map.toList (elabInstantiatedWith elab)
+ | (k, v) <- Map.toList (compInstantiatedWith comp)
]
nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
@@ -1184,11 +1176,13 @@ printPlan
showConfigureFlags :: ElaboratedConfiguredPackage -> String
showConfigureFlags elab =
- let commonFlags =
+ let Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains elaboratedShared) (elabStage elab)
+ commonFlags =
setupHsCommonFlags
verbosity
Nothing -- omit working directory
(makeSymbolicPath "$builddir")
+ (setupHsConfigureArgs elab)
buildSettingKeepTempFiles
fullConfigureFlags =
runIdentity
@@ -1223,7 +1217,7 @@ printPlan
in -- Not necessary to "escape" it, it's just for user output
unwords . ("" :) $
commandShowOptions
- (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
+ (Setup.configureCommand toolchainProgramDb)
partialConfigureFlags
showBuildStatus :: BuildStatus -> String
@@ -1255,7 +1249,8 @@ printPlan
showBuildProfile =
"Build profile: "
++ unwords
- [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared
+ [ "-w " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Host)
+ , "-W " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Build)
, "-O"
++ ( case globalOptimization <> localOptimization of -- if local is not set, read global
Setup.Flag NoOptimisation -> "0"
@@ -1266,53 +1261,53 @@ printPlan
]
++ "\n"
-writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
-writeBuildReports settings buildContext plan buildOutcomes = do
- let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext
- comp = pkgConfigCompiler . elaboratedShared $ buildContext
- getRepo (RepoTarballPackage r _ _) = Just r
- getRepo _ = Nothing
- fromPlanPackage (InstallPlan.Configured pkg) (Just result) =
- let installOutcome = case result of
- Left bf -> case buildFailureReason bf of
- GracefulFailure _ -> BuildReports.PlanningFailed
- DependentFailed p -> BuildReports.DependencyFailed p
- DownloadFailed _ -> BuildReports.DownloadFailed
- UnpackFailed _ -> BuildReports.UnpackFailed
- ConfigureFailed _ -> BuildReports.ConfigureFailed
- BuildFailed _ -> BuildReports.BuildFailed
- TestsFailed _ -> BuildReports.TestsFailed
- InstallFailed _ -> BuildReports.InstallFailed
- ReplFailed _ -> BuildReports.InstallOk
- HaddocksFailed _ -> BuildReports.InstallOk
- BenchFailed _ -> BuildReports.InstallOk
- Right _br -> BuildReports.InstallOk
-
- docsOutcome = case result of
- Left bf -> case buildFailureReason bf of
- HaddocksFailed _ -> BuildReports.Failed
- _ -> BuildReports.NotTried
- Right br -> case buildResultDocs br of
- DocsNotTried -> BuildReports.NotTried
- DocsFailed -> BuildReports.Failed
- DocsOk -> BuildReports.Ok
-
- testsOutcome = case result of
- Left bf -> case buildFailureReason bf of
- TestsFailed _ -> BuildReports.Failed
- _ -> BuildReports.NotTried
- Right br -> case buildResultTests br of
- TestsNotTried -> BuildReports.NotTried
- TestsOk -> BuildReports.Ok
- in Just (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?
- fromPlanPackage _ _ = Nothing
- buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan
-
- BuildReports.storeLocal
- (compilerInfo comp)
- (buildSettingSummaryFile settings)
- buildReports
- plat
+-- writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
+-- writeBuildReports settings buildContext plan buildOutcomes = do
+-- let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext
+-- comp = pkgConfigCompiler . elaboratedShared $ buildContext
+-- getRepo (RepoTarballPackage r _ _) = Just r
+-- getRepo _ = Nothing
+-- fromPlanPackage (InstallPlan.Configured pkg) (Just result) =
+-- let installOutcome = case result of
+-- Left bf -> case buildFailureReason bf of
+-- GracefulFailure _ -> BuildReports.PlanningFailed
+-- DependentFailed p -> BuildReports.DependencyFailed p
+-- DownloadFailed _ -> BuildReports.DownloadFailed
+-- UnpackFailed _ -> BuildReports.UnpackFailed
+-- ConfigureFailed _ -> BuildReports.ConfigureFailed
+-- BuildFailed _ -> BuildReports.BuildFailed
+-- TestsFailed _ -> BuildReports.TestsFailed
+-- InstallFailed _ -> BuildReports.InstallFailed
+-- ReplFailed _ -> BuildReports.InstallOk
+-- HaddocksFailed _ -> BuildReports.InstallOk
+-- BenchFailed _ -> BuildReports.InstallOk
+-- Right _br -> BuildReports.InstallOk
+
+-- docsOutcome = case result of
+-- Left bf -> case buildFailureReason bf of
+-- HaddocksFailed _ -> BuildReports.Failed
+-- _ -> BuildReports.NotTried
+-- Right br -> case buildResultDocs br of
+-- DocsNotTried -> BuildReports.NotTried
+-- DocsFailed -> BuildReports.Failed
+-- DocsOk -> BuildReports.Ok
+
+-- testsOutcome = case result of
+-- Left bf -> case buildFailureReason bf of
+-- TestsFailed _ -> BuildReports.Failed
+-- _ -> BuildReports.NotTried
+-- Right br -> case buildResultTests br of
+-- TestsNotTried -> BuildReports.NotTried
+-- TestsOk -> BuildReports.Ok
+-- in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?
+-- fromPlanPackage _ _ = Nothing
+-- buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan
+
+-- BuildReports.storeLocal
+-- (compilerInfo comp)
+-- (buildSettingSummaryFile settings)
+-- buildReports
+-- plat
-- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1
-- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle.
@@ -1359,7 +1354,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
, (pkg, failureClassification) <- failuresClassification
]
where
- failures :: [(UnitId, BuildFailure)]
+ failures :: [(Graph.Key ElaboratedPlanPackage, BuildFailure)]
failures =
[ (pkgid, failure)
| (pkgid, Left failure) <- Map.toList buildOutcomes
@@ -1417,9 +1412,10 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
--
isSimpleCase :: Bool
isSimpleCase
- | [(pkgid, failure)] <- failures
+ | [(WithStage s pkgid, failure)] <- failures
, [pkg] <- rootpkgs
, installedUnitId pkg == pkgid
+ , stageOf pkg == s
, isFailureSelfExplanatory (buildFailureReason failure)
, currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] =
True
@@ -1443,16 +1439,15 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
, hasNoDependents pkg
]
- ultimateDeps
- :: UnitId
- -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage]
- ultimateDeps pkgid =
+ ultimateDeps :: (WithStage UnitId) -> [ElaboratedPlanPackage]
+ ultimateDeps pkgid@(WithStage s uid) =
filter
- (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
+ (\pkg -> hasNoDependents pkg && installedUnitId pkg /= uid && stageOf pkg == s)
(InstallPlan.reverseDependencyClosure plan [pkgid])
- hasNoDependents :: HasUnitId pkg => pkg -> Bool
- hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId
+ -- TODO: ugly
+ hasNoDependents :: (Graph.IsNode pkg, Graph.Key pkg ~ WithStage UnitId) => pkg -> Bool
+ hasNoDependents = null . InstallPlan.revDirectDeps plan . Graph.nodeKey
renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail mentionDepOf pkg reason =
@@ -1466,7 +1461,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
case reason of
DownloadFailed _ -> "Failed to download " ++ pkgstr
UnpackFailed _ -> "Failed to unpack " ++ pkgstr
- ConfigureFailed _ -> "Failed to build " ++ pkgstr
+ ConfigureFailed _ -> "Failed to configure " ++ pkgstr
BuildFailed _ -> "Failed to build " ++ pkgstr
ReplFailed _ -> "repl failed for " ++ pkgstr
HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr
@@ -1476,7 +1471,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
GracefulFailure msg -> msg
DependentFailed depid ->
"Failed to build "
- ++ prettyShow (packageId pkg)
+ ++ prettyShow (Graph.nodeKey pkg)
++ " because it depends on "
++ prettyShow depid
++ " which itself failed to build"
@@ -1484,7 +1479,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
pkgstr =
elabConfiguredName verbosity pkg
++ if mentionDepOf
- then renderDependencyOf (installedUnitId pkg)
+ then renderDependencyOf (Graph.nodeKey pkg)
else ""
renderFailureExtraDetail :: BuildFailureReason -> String
@@ -1495,7 +1490,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
renderFailureExtraDetail _ =
""
- renderDependencyOf :: UnitId -> String
+ renderDependencyOf :: Graph.Key ElaboratedConfiguredPackage -> String
renderDependencyOf pkgid =
case ultimateDeps pkgid of
[] -> ""
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
index 880770693fd..fbec1e50554 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
@@ -1,7 +1,5 @@
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.ProjectPlanOutput
( -- * Plan output
@@ -32,6 +30,7 @@ import qualified Distribution.Client.Utils.Json as J
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
+import qualified Distribution.Solver.Types.Stage as Stage
import qualified Distribution.Compat.Binary as Binary
import Distribution.Compat.Graph (Graph, Node)
@@ -78,6 +77,7 @@ import System.FilePath
import System.IO
import Distribution.Simple.Program.GHC (packageDbArgsDb)
+import GHC.Stack (HasCallStack)
-----------------------------------------------------------------------------
-- Writing plan.json files
@@ -106,20 +106,26 @@ encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedCo
encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
-- TODO: [nice to have] include all of the sharedPackageConfig and all of
-- the parts of the elaboratedInstallPlan
- J.object
+ J.object $
[ "cabal-version" J..= jdisplay cabalInstallVersion
, "cabal-lib-version" J..= jdisplay cabalVersion
- , "compiler-id"
- J..= (J.String . showCompilerId . pkgConfigCompiler)
- elaboratedSharedConfig
- , "compiler-abi" J..= jdisplay (compilerAbiTag (pkgConfigCompiler elaboratedSharedConfig))
- , "os" J..= jdisplay os
- , "arch" J..= jdisplay arch
- , "install-plan" J..= installPlanToJ elaboratedInstallPlan
]
+ ++ toolchainJ Host
+ ++ toolchainJ Build
+ ++ ["install-plan" J..= installPlanToJ elaboratedInstallPlan]
where
- plat :: Platform
- plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig
+ toolchains = pkgConfigToolchains elaboratedSharedConfig
+
+ toolchainJ stage =
+ [ prefixed "compiler-id" J..= J.String (showCompilerId toolchainCompiler)
+ , prefixed "arch" J..= (jdisplay arch)
+ , prefixed "os" J..= (jdisplay os)
+ ]
+ where
+ Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} = Stage.getStage toolchains stage
+ prefixed s = case stage of
+ Stage.Build -> "build-" ++ s
+ Stage.Host -> s
installPlanToJ :: ElaboratedInstallPlan -> [J.Value]
installPlanToJ = map planPackageToJ . InstallPlan.toList
@@ -135,7 +141,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
-- that case, but the code supports it in case we want to use this
-- later in some use case where we want the status of the build.
- installedPackageInfoToJ :: InstalledPackageInfo -> J.Value
+ installedPackageInfoToJ :: WithStage InstalledPackageInfo -> J.Value
installedPackageInfoToJ ipi =
-- Pre-existing packages lack configuration information such as their flag
-- settings or non-lib components. We only get pre-existing packages for
@@ -144,10 +150,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
--
J.object
[ "type" J..= J.String "pre-existing"
- , "id" J..= (jdisplay . installedUnitId) ipi
+ , "stage" J..= jdisplay (stageOf ipi)
+ , "id" J..= (jdisplay . Graph.nodeKey) ipi
, "pkg-name" J..= (jdisplay . pkgName . packageId) ipi
, "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi
- , "depends" J..= map jdisplay (installedDepends ipi)
+ , "depends" J..= map jdisplay (traverse installedDepends ipi)
]
elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value
@@ -159,7 +166,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
then "installed"
else "configured"
)
- , "id" J..= (jdisplay . installedUnitId) elab
+ , "id" J..= (jdisplay . Graph.nodeKey) elab
+ , "stage" J..= jdisplay (elabStage elab)
, "pkg-name" J..= (jdisplay . pkgName . packageId) elab
, "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab
, -- The `x-revision` field is a feature of repos (not cabal itself),
@@ -195,7 +203,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
[ comp2str c
J..= J.object
( [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps)
- , "exe-depends" J..= map (jdisplay . confInstId) edeps
+ , "exe-depends" J..= map (jdisplay . fmap confInstId) edeps
]
++ bin_file c
)
@@ -207,12 +215,15 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
]
in ["components" J..= components]
ElabComponent comp ->
- [ "depends" J..= map (jdisplay . confInstId) (map fst $ elabLibDependencies elab)
+ [ "depends" J..= map (jdisplay . fmap confInstId . fst) (elabLibDependencies elab)
, "exe-depends" J..= map jdisplay (elabExeDependencies elab)
, "component-name" J..= J.String (comp2str (compSolverName comp))
]
++ bin_file (compSolverName comp)
where
+ Toolchain{toolchainPlatform = plat} =
+ Stage.getStage toolchains (elabStage elab)
+
-- \| Only add build-info file location if the Setup.hs CLI
-- is recent enough to be able to generate build info files.
-- Otherwise, write 'null'.
@@ -457,7 +468,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
-- successfully then they're still out of date -- meeting our definition of
-- invalid.
-type PackageIdSet = Set UnitId
+type PackageIdSet = Set (Graph.Key ElaboratedPlanPackage)
type PackagesUpToDate = PackageIdSet
data PostBuildProjectStatus = PostBuildProjectStatus
@@ -510,7 +521,7 @@ data PostBuildProjectStatus = PostBuildProjectStatus
-- or data file generation failing.
--
-- This is a subset of 'packagesInvalidByChangedLibDeps'.
- , packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
+ , packagesLibDepGraph :: Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage)
-- ^ A subset of the plan graph, including only dependency-on-library
-- edges. That is, dependencies /on/ libraries, not dependencies /of/
-- libraries. This tells us all the libraries that packages link to.
@@ -533,7 +544,8 @@ data PostBuildProjectStatus = PostBuildProjectStatus
-- | Work out which packages are out of date or invalid after a build.
postBuildProjectStatus
- :: ElaboratedInstallPlan
+ :: HasCallStack
+ => ElaboratedInstallPlan
-> PackagesUpToDate
-> BuildStatusMap
-> BuildOutcomes
@@ -579,11 +591,13 @@ postBuildProjectStatus
-- The previous set of up-to-date packages will contain bogus package ids
-- when the solver plan or config contributing to the hash changes.
-- So keep only the ones where the package id (i.e. hash) is the same.
+ previousPackagesUpToDate' :: Set (WithStage UnitId)
previousPackagesUpToDate' =
Set.intersection
previousPackagesUpToDate
(InstallPlan.keysSet plan)
+ packagesUpToDatePreBuild :: Set (WithStage UnitId)
packagesUpToDatePreBuild =
Set.filter
(\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid))
@@ -591,23 +605,26 @@ postBuildProjectStatus
-- know anything about their status, so not known to be /up to date/.
(InstallPlan.keysSet plan)
+ packagesOutOfDatePreBuild :: Set (WithStage UnitId)
packagesOutOfDatePreBuild =
- Set.fromList . map installedUnitId $
+ Set.fromList . map Graph.nodeKey $
InstallPlan.reverseDependencyClosure
plan
[ ipkgid
| pkg <- InstallPlan.toList plan
- , let ipkgid = installedUnitId pkg
+ , let ipkgid = Graph.nodeKey pkg
, lookupBuildStatusRequiresBuild False ipkgid
-- For packages not in the plan subset we did the dry-run on we don't
-- know anything about their status, so not known to be /out of date/.
]
+ packagesSuccessfulPostBuild :: Set (WithStage UnitId)
packagesSuccessfulPostBuild =
Set.fromList
[ikgid | (ikgid, Right _) <- Map.toList buildOutcomes]
-- direct failures, not failures due to deps
+ packagesFailurePostBuild :: Set (WithStage UnitId)
packagesFailurePostBuild =
Set.fromList
[ ikgid
@@ -619,6 +636,7 @@ postBuildProjectStatus
-- Packages that have a library dependency on a package for which a build
-- was attempted
+ packagesDepOnChangedLib :: Set (WithStage UnitId)
packagesDepOnChangedLib =
Set.fromList . map Graph.nodeKey $
fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $
@@ -630,19 +648,25 @@ postBuildProjectStatus
)
-- The plan graph but only counting dependency-on-library edges
- packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
+ packagesLibDepGraph :: HasCallStack => Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage)
packagesLibDepGraph =
Graph.fromDistinctList
- [ Graph.N pkg (installedUnitId pkg) libdeps
+ [ Graph.N pkg (Graph.nodeKey pkg) libdeps
| pkg <- InstallPlan.toList plan
, let libdeps = case pkg of
- InstallPlan.PreExisting ipkg -> installedDepends ipkg
- InstallPlan.Configured srcpkg -> elabLibDeps srcpkg
- InstallPlan.Installed srcpkg -> elabLibDeps srcpkg
+ InstallPlan.PreExisting (WithStage s ipkg) -> map (WithStage s) (installedDepends ipkg)
+ InstallPlan.Configured srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg)
+ InstallPlan.Installed srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg)
]
elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]
- elabLibDeps = map (newSimpleUnitId . confInstId) . map fst . elabLibDependencies
+ elabLibDeps =
+ map (newSimpleUnitId . confInstId)
+ -- Note, we remove the stage here. In the end we only care about the hash which already incorporates the stage.
+ -- Moreover, library dependencies are always in the same stage as the package itself.
+ . map (\(WithStage _ d) -> d)
+ . map fst
+ . elabLibDependencies
-- Was a build was attempted for this package?
-- If it doesn't have both a build status and outcome then the answer is no.
@@ -659,13 +683,13 @@ postBuildProjectStatus
buildAttempted _ (Left BuildFailure{}) = True
buildAttempted _ (Right _) = True
- lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool
- lookupBuildStatusRequiresBuild def ipkgid =
- case Map.lookup ipkgid pkgBuildStatus of
+ lookupBuildStatusRequiresBuild :: Bool -> Graph.Key ElaboratedPlanPackage -> Bool
+ lookupBuildStatusRequiresBuild def key =
+ case Map.lookup key pkgBuildStatus of
Nothing -> def -- Not in the plan subset we did the dry-run on
Just buildStatus -> buildStatusRequiresBuild buildStatus
- packagesBuildLocal :: Set UnitId
+ packagesBuildLocal :: Set (WithStage UnitId)
packagesBuildLocal =
selectPlanPackageIdSet $ \pkg ->
case pkg of
@@ -673,7 +697,7 @@ postBuildProjectStatus
InstallPlan.Installed _ -> False
InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg
- packagesBuildInplace :: Set UnitId
+ packagesBuildInplace :: Set (WithStage UnitId)
packagesBuildInplace =
selectPlanPackageIdSet $ \pkg ->
case pkg of
@@ -681,7 +705,7 @@ postBuildProjectStatus
InstallPlan.Installed _ -> False
InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg)
- packagesAlreadyInStore :: Set UnitId
+ packagesAlreadyInStore :: Set (WithStage UnitId)
packagesAlreadyInStore =
selectPlanPackageIdSet $ \pkg ->
case pkg of
@@ -690,10 +714,8 @@ postBuildProjectStatus
InstallPlan.Configured _ -> False
selectPlanPackageIdSet
- :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
- -> Bool
- )
- -> Set UnitId
+ :: (ElaboratedPlanPackage -> Bool)
+ -> Set (Graph.Key ElaboratedPlanPackage)
selectPlanPackageIdSet p =
Map.keysSet
. Map.filter p
@@ -819,11 +841,16 @@ createPackageEnvironmentAndArgs
elaboratedPlan
elaboratedShared
buildStatus
- | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC =
+ | buildCompiler /= hostCompiler =
+ do
+ warn verbosity "package environment configuration is not supported for cross-compilation; commands that need the current project's package database are likely to fail"
+ return ([], [])
+ | compilerFlavor hostCompiler == GHC =
do
envFileM <-
writePlanGhcEnvironment
path
+ Host
elaboratedPlan
elaboratedShared
buildStatus
@@ -836,55 +863,42 @@ createPackageEnvironmentAndArgs
do
warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"
return ([], [])
+ where
+ compilers = toolchainCompiler <$> pkgConfigToolchains elaboratedShared
+ buildCompiler = getStage compilers Build
+ hostCompiler = getStage compilers Host
-- Writing .ghc.environment files
--
writePlanGhcEnvironment
:: FilePath
+ -> Stage
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO (Maybe FilePath)
writePlanGhcEnvironment
path
+ stage
elaboratedInstallPlan
- ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigPlatform = platform
- }
- postBuildStatus
- | compilerFlavor compiler == GHC
- , supportsPkgEnvFiles (getImplInfo compiler) =
- -- TODO: check ghcjs compat
+ elaboratedSharedConfig
+ postBuildStatus =
+ if (compilerFlavor toolchainCompiler == GHC && supportsPkgEnvFiles (getImplInfo toolchainCompiler))
+ then -- TODO: check ghcjs compat
+
fmap Just $
writeGhcEnvironmentFile
path
- platform
- (compilerVersion compiler)
- ( renderGhcEnvironmentFile
- path
- elaboratedInstallPlan
- postBuildStatus
- )
--- TODO: [required eventually] support for writing user-wide package
--- environments, e.g. like a global project, but we would not put the
--- env file in the home dir, rather it lives under ~/.ghc/
+ toolchainPlatform
+ (compilerVersion toolchainCompiler)
+ env
+ else return Nothing
+ where
+ Toolchain{toolchainPlatform, toolchainCompiler} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage
-writePlanGhcEnvironment _ _ _ _ = return Nothing
+ env = headerComment : simpleGhcEnvironmentFile packageDBs unitIds
-renderGhcEnvironmentFile
- :: FilePath
- -> ElaboratedInstallPlan
- -> PostBuildProjectStatus
- -> [GhcEnvironmentFileEntry FilePath]
-renderGhcEnvironmentFile
- projectRootDir
- elaboratedInstallPlan
- postBuildStatus =
- headerComment
- : simpleGhcEnvironmentFile packageDBs unitIds
- where
headerComment =
GhcEnvFileComment $
"This is a GHC environment file written by cabal. This means you can\n"
@@ -892,11 +906,17 @@ renderGhcEnvironmentFile
++ "But you still need to use cabal repl $target to get the environment\n"
++ "of specific components (libs, exes, tests etc) because each one can\n"
++ "have its own source dirs, cpp flags etc.\n\n"
- unitIds = selectGhcEnvironmentFileLibraries postBuildStatus
+
+ unitIds = [unitId | WithStage Host unitId <- selectGhcEnvironmentFileLibraries postBuildStatus]
+
packageDBs =
- relativePackageDBPaths projectRootDir $
+ relativePackageDBPaths path $
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
+-- TODO: [required eventually] support for writing user-wide package
+-- environments, e.g. like a global project, but we would not put the
+-- env file in the home dir, rather it lives under ~/.ghc/
+
argsEquivalentOfGhcEnvironmentFile
:: Compiler
-> DistDirLayout
@@ -964,7 +984,7 @@ argsEquivalentOfGhcEnvironmentFileGhc
-- to find the libs) then those exes still end up in our list so we have
-- to filter them out at the end.
--
-selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
+selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [WithStage UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =
case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of
Nothing -> error "renderGhcEnvironmentFile: broken dep closure"
@@ -981,7 +1001,7 @@ selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =
-- or just locally. Check it's a lib and that it is probably up to date.
InstallPlan.Configured pkg ->
elabRequiresRegistration pkg
- && installedUnitId pkg `Set.member` packagesProbablyUpToDate
+ && Graph.nodeKey pkg `Set.member` packagesProbablyUpToDate
selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
index 3dbf2977407..9c72ebf204d 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -36,12 +36,21 @@
module Distribution.Client.ProjectPlanning
( -- * Types for the elaborated install plan
ElaboratedInstallPlan
+ , ElaboratedInstalledPackageInfo
, ElaboratedConfiguredPackage (..)
, ElaboratedPlanPackage
, ElaboratedSharedConfig (..)
, ElaboratedReadyPackage
, BuildStyle (..)
, CabalFileText
+ , Toolchain (..)
+ , Stage (..)
+ , Staged (..)
+ , WithStage (..)
+ , elabOrderLibDependencies
+ , elabOrderExeDependencies
+ , elabLibDependencies
+ , elabExeDependencies
-- * Reading the project configuration
-- $readingTheProjectConfiguration
@@ -69,7 +78,7 @@ module Distribution.Client.ProjectPlanning
-- * Utils required for building
, pkgHasEphemeralBuildTargets
, elabBuildTargetWholeComponents
- , configureCompiler
+ , configureToolchains
-- * Setup.hs CLI flags for building
, setupHsScriptOptions
@@ -95,12 +104,12 @@ module Distribution.Client.ProjectPlanning
, binDirectories
, storePackageInstallDirs
, storePackageInstallDirs'
+ , elabDistDirParams
) where
import Distribution.Client.Compat.Prelude
import Text.PrettyPrint
- ( colon
- , comma
+ ( comma
, fsep
, hang
, punctuate
@@ -126,7 +135,6 @@ import Distribution.Client.ProjectConfig.Types (defaultProjectFileParser)
import Distribution.Client.ProjectPlanOutput
import Distribution.Client.ProjectPlanning.SetupPolicy
( NonSetupLibDepSolverPlanPackage (..)
- , mkDefaultSetupDeps
, packageSetupScriptSpecVersion
, packageSetupScriptStyle
)
@@ -136,8 +144,9 @@ import Distribution.Client.Setup hiding (cabalVersion, packageName)
import Distribution.Client.SetupWrapper
import Distribution.Client.Store
import Distribution.Client.Targets (userToPackageConstraint)
+import Distribution.Client.Toolchain
import Distribution.Client.Types
-import Distribution.Client.Utils (concatMapM, incVersion)
+import Distribution.Client.Utils (concatMapM)
import qualified Distribution.Client.BuildReports.Storage as BuildReports
import qualified Distribution.Client.IndexUtils as IndexUtils
@@ -197,7 +206,7 @@ import Distribution.Types.PackageVersionConstraint
import Distribution.Types.PkgconfigDependency
import Distribution.Types.UnqualComponentName
-import Distribution.Backpack
+import Distribution.Backpack hiding (mkDefUnitId)
import Distribution.Backpack.ComponentsGraph
import Distribution.Backpack.ConfiguredComponent
import Distribution.Backpack.FullUnitId
@@ -222,16 +231,20 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD
import qualified Distribution.Compat.Graph as Graph
import Control.Exception (assert)
-import Control.Monad (sequence)
+import Control.Monad (mapM_, sequence)
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.State as State (State, execState, runState, state)
+import Control.Monad.State (State, execState, gets, modify)
import Data.Foldable (fold)
import Data.List (deleteBy, groupBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Client.Errors
+import Distribution.Client.InstallPlan (foldPlanPackage)
import Distribution.Solver.Types.ProjectConfigPath
+import Distribution.Solver.Types.ResolverPackage (solverId)
+import qualified Distribution.Solver.Types.ResolverPackage as ResolverPackage
+import GHC.Stack (HasCallStack)
import System.Directory (getCurrentDirectory)
import System.FilePath
import qualified Text.PrettyPrint as Disp
@@ -379,9 +392,9 @@ rebuildProjectConfig
configPath <- getConfigFilePath verbosity projectConfigConfigFile
return
( configPath
- , distProjectFileMain distProjectFile
- , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg)
+ , distProjectFile ""
, projectConfigProjectFileParser
+ , projectConfigToolchain
, progsearchpath
, packageConfigProgramPaths
, packageConfigProgramPathExtra
@@ -400,21 +413,23 @@ rebuildProjectConfig
let fetchCompiler = do
-- have to create the cache directory before configuring the compiler
liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
- (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
- pure (os, arch, compiler)
+ toolchains <- configureToolchains verbosity distDirLayout (snd (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
+ -- The project configuration is always done with the host compiler
+ let Toolchain{toolchainCompiler = compiler, toolchainPlatform = Platform arch os} = getStage toolchains Host
+ return (os, arch, compiler)
- (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
- when (projectConfigDistDir (projectConfigShared projectConfig) /= NoFlag) $
+ (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
+ when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $
liftIO $
warn verbosity "The builddir option is not supported in project and config files. It will be ignored."
- localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig)
+ localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig)
return (projectConfig, localPackages)
informAboutConfigFiles projectConfig
return (projectConfig <> cliConfig, localPackages)
where
- ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile} =
+ ProjectConfigShared{projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile, projectConfigToolchain} =
projectConfigShared cliConfig
PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} =
@@ -435,11 +450,9 @@ rebuildProjectConfig
-- NOTE: These are all packages mentioned in the project configuration.
-- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`.
phaseReadLocalPackages
- :: Maybe Compiler
- -> ProjectConfig
+ :: ProjectConfig
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
phaseReadLocalPackages
- compiler
projectConfig@ProjectConfig
{ projectConfigShared
, projectConfigBuildOnly
@@ -454,7 +467,6 @@ rebuildProjectConfig
fetchAndReadSourcePackages
verbosity
distDirLayout
- compiler
projectConfigShared
projectConfigBuildOnly
pkgLocations
@@ -500,12 +512,12 @@ rebuildProjectConfig
$ projectConfigProvenance projectConfig
]
-configureCompiler
+configureToolchains
:: Verbosity
-> DistDirLayout
-> ProjectConfig
- -> Rebuild (Compiler, Platform, ProgramDb)
-configureCompiler
+ -> Rebuild Toolchains
+configureToolchains
verbosity
DistDirLayout
{ distProjectCacheFile
@@ -513,9 +525,17 @@ configureCompiler
ProjectConfig
{ projectConfigShared =
ProjectConfigShared
- { projectConfigHcFlavor
- , projectConfigHcPath
- , projectConfigHcPkg
+ { projectConfigToolchain =
+ ProjectConfigToolchain
+ { projectConfigHcFlavor
+ , projectConfigHcPath
+ , projectConfigHcPkg
+ , projectConfigPackageDBs
+ , projectConfigBuildHcFlavor
+ , projectConfigBuildHcPath
+ , projectConfigBuildHcPkg
+ , projectConfigBuildPackageDBs
+ }
, projectConfigProgPathExtra
}
, projectConfigLocalPackages =
@@ -524,17 +544,54 @@ configureCompiler
, packageConfigProgramPathExtra
}
} = do
- let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler"
+ let fileMonitorBuildCompiler = newFileMonitor $ distProjectCacheFile "build-compiler"
+ fileMonitorHostCompiler = newFileMonitor $ distProjectCacheFile "host-compiler"
progsearchpath <- liftIO getSystemSearchPath
- (hc, plat, hcProgDb) <-
+ (buildHc, buildPlat, buildHcProgDb) <-
+ rerunIfChanged
+ verbosity
+ fileMonitorBuildCompiler
+ ( buildHcFlavor
+ , buildHcPath
+ , buildHcPkg
+ , progsearchpath
+ , packageConfigProgramPaths
+ , packageConfigProgramPathExtra
+ )
+ $ do
+ liftIO $ info verbosity "Compiler settings changed, reconfiguring..."
+ progdb <-
+ liftIO $
+ -- Add paths in the global config
+ prependProgramSearchPath verbosity (fromNubList projectConfigProgPathExtra) [] defaultProgramDb
+ -- Add paths in the local config
+ >>= prependProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) []
+ >>= pure . userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
+ result@(_, _, progdb') <-
+ liftIO $
+ Cabal.configCompiler
+ buildHcFlavor
+ buildHcPath
+ progdb
+ verbosity
+ -- Note that we added the user-supplied program locations and args
+ -- for /all/ programs, not just those for the compiler prog and
+ -- compiler-related utils. In principle we don't know which programs
+ -- the compiler will configure (and it does vary between compilers).
+ -- We do know however that the compiler will only configure the
+ -- programs it cares about, and those are the ones we monitor here.
+ monitorFiles (programsMonitorFiles progdb')
+ return result
+
+ (hostHc, hostPlat, hostHcProgDb) <-
rerunIfChanged
verbosity
- fileMonitorCompiler
- ( hcFlavor
- , hcPath
- , hcPkg
+ fileMonitorHostCompiler
+ ( hostHcFlavor
+ , hostHcPath
+ , hostHcPkg
, progsearchpath
, packageConfigProgramPaths
, packageConfigProgramPathExtra
@@ -551,8 +608,8 @@ configureCompiler
result@(_, _, progdb') <-
liftIO $
Cabal.configCompiler
- hcFlavor
- hcPath
+ hostHcFlavor
+ hostHcPath
progdb
verbosity
-- Note that we added the user-supplied program locations and args
@@ -568,12 +625,32 @@ configureCompiler
-- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...).
--
-- See Note [Caching the result of configuring the compiler]
- finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc hcProgDb hcPkg
- return (hc, plat, finalProgDb)
+ finalBuildProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity buildHc buildHcProgDb buildHcPkg
+ finalHostProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hostHc hostHcProgDb hostHcPkg
+
+ return $ Staged $ \case
+ Build ->
+ Toolchain
+ { toolchainCompiler = buildHc
+ , toolchainPlatform = buildPlat
+ , toolchainProgramDb = finalBuildProgDb
+ , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigBuildPackageDBs
+ }
+ Host ->
+ Toolchain
+ { toolchainCompiler = hostHc
+ , toolchainPlatform = hostPlat
+ , toolchainProgramDb = finalHostProgDb
+ , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigPackageDBs
+ }
where
- hcFlavor = flagToMaybe projectConfigHcFlavor
- hcPath = flagToMaybe projectConfigHcPath
- hcPkg = flagToMaybe projectConfigHcPkg
+ hostHcFlavor = flagToMaybe projectConfigHcFlavor
+ hostHcPath = flagToMaybe projectConfigHcPath
+ hostHcPkg = flagToMaybe projectConfigHcPkg
+ -- Use the host compiler if a separate build compiler is not specified
+ buildHcFlavor = flagToMaybe projectConfigBuildHcFlavor <|> flagToMaybe projectConfigHcFlavor
+ buildHcPath = flagToMaybe projectConfigBuildHcPath <|> flagToMaybe projectConfigHcPath
+ buildHcPkg = flagToMaybe projectConfigBuildHcPkg <|> flagToMaybe projectConfigHcPkg
{- Note [Caching the result of configuring the compiler]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -678,27 +755,30 @@ rebuildInstallPlan
, progsearchpath
)
$ do
- compilerEtc <- phaseConfigureCompiler projectConfig
- _ <- phaseConfigurePrograms projectConfig compilerEtc
- (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <-
+ toolchains <- phaseConfigureToolchains projectConfig
+ phaseConfigurePrograms projectConfig toolchains
+ (solverPlan, _, pkgConfigDBs, totalIndexState, activeRepos) <-
phaseRunSolver
projectConfig
- compilerEtc
+ toolchains
localPackages
(fromMaybe mempty mbInstalledPackages)
- ( elaboratedPlan
- , elaboratedShared
- ) <-
+
+ (elaboratedPlan, elaboratedShared) <-
phaseElaboratePlan
projectConfig
- compilerEtc
- pkgConfigDB
+ toolchains
+ pkgConfigDBs
solverPlan
localPackages
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
+ -- \| Given the 'InstalledPackageIndex' for a nix-style package store, and an
+ -- 'ElaboratedInstallPlan', replace configured source packages by installed
+ -- packages from the store whenever they exist.
+ --
-- The improved plan changes each time we install something, whereas
-- the underlying elaborated plan only changes when input config
-- changes, so it's worth caching them separately.
@@ -715,14 +795,20 @@ rebuildInstallPlan
newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile
-- Configure the compiler we're using.
- --
+
-- This is moderately expensive and doesn't change that often so we cache
-- it independently.
--
- phaseConfigureCompiler
+ phaseConfigureToolchains
:: ProjectConfig
- -> Rebuild (Compiler, Platform, ProgramDb)
- phaseConfigureCompiler = configureCompiler verbosity distDirLayout
+ -> Rebuild Toolchains
+ phaseConfigureToolchains projectConfig = do
+ toolchains <- configureToolchains verbosity distDirLayout projectConfig
+ liftIO $ do
+ putStrLn "Toolchains:"
+ for_ stages $ \s ->
+ print $ Disp.hsep [Disp.text "-" <+> pretty s <+> Disp.text "compiler" <+> pretty (compilerId (toolchainCompiler (getStage toolchains s)))]
+ return toolchains
-- Configuring other programs.
--
@@ -738,17 +824,18 @@ rebuildInstallPlan
--
phaseConfigurePrograms
:: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
+ -> Toolchains
-> Rebuild ()
- phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do
+ phaseConfigurePrograms projectConfig toolchains = do
-- Users are allowed to specify program locations independently for
-- each package (e.g. to use a particular version of a pre-processor
-- for some packages). However they cannot do this for the compiler
-- itself as that's just not going to work. So we check for this.
- liftIO $
- checkBadPerPackageCompilerPaths
- (configuredPrograms compilerprogdb)
- (getMapMappend (projectConfigSpecificPackage projectConfig))
+ for_ toolchains $ \Toolchain{toolchainProgramDb} ->
+ liftIO $
+ checkBadPerPackageCompilerPaths
+ (configuredPrograms toolchainProgramDb)
+ (getMapMappend (projectConfigSpecificPackage projectConfig))
-- TODO: [required eventually] find/configure other programs that the
-- user specifies.
@@ -761,43 +848,42 @@ rebuildInstallPlan
--
phaseRunSolver
:: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
+ -> Toolchains
-> [PackageSpecifier UnresolvedSourcePackage]
-> InstalledPackageIndex
- -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
+ -> Rebuild
+ ( SolverInstallPlan
+ , Staged InstalledPackageIndex
+ , Staged (Maybe PkgConfigDb)
+ , IndexUtils.TotalIndexState
+ , IndexUtils.ActiveRepos
+ )
phaseRunSolver
projectConfig@ProjectConfig
{ projectConfigShared
, projectConfigBuildOnly
}
- (compiler, platform, progdb)
+ toolchains
localPackages
- installedPackages =
+ _installedPackages =
rerunIfChanged
verbosity
fileMonitorSolverPlan
( solverSettings
, localPackages
, localPackagesEnabledStanzas
- , compiler
- , platform
- , programDbSignature progdb
+ , toolchains
)
$ do
- installedPkgIndex <-
- getInstalledPackages
- verbosity
- compiler
- progdb
- platform
- corePackageDbs
(sourcePkgDb, tis, ar) <-
getSourcePackages
verbosity
withRepoCtx
(solverSettingIndexState solverSettings)
(solverSettingActiveRepos solverSettings)
- pkgConfigDB <- getPkgConfigDb verbosity progdb
+
+ ipis <- for toolchains (getInstalledPackages verbosity)
+ pkgConfigDbs <- for toolchains (getPkgConfigDb verbosity . toolchainProgramDb)
-- TODO: [code cleanup] it'd be better if the Compiler contained the
-- ConfiguredPrograms that it needs, rather than relying on the progdb
@@ -810,23 +896,25 @@ rebuildInstallPlan
foldProgress logMsg (pure . Left) (pure . Right) $
planPackages
verbosity
- compiler
- platform
solverSettings
- (installedPackages <> installedPkgIndex)
+ compilerAndPlatform
+ pkgConfigDbs
+ ipis
sourcePkgDb
- pkgConfigDB
localPackages
localPackagesEnabledStanzas
case planOrError of
Left msg -> do
- reportPlanningFailure projectConfig compiler platform localPackages
+ -- TODO
+ for_ toolchains $ \(Toolchain{toolchainCompiler, toolchainPlatform}) ->
+ reportPlanningFailure projectConfig toolchainCompiler toolchainPlatform localPackages
dieWithException verbosity $ PhaseRunSolverErr msg
- Right plan -> return (plan, pkgConfigDB, tis, ar)
+ Right plan -> return (plan, ipis, pkgConfigDbs, tis, ar)
where
- corePackageDbs :: PackageDBStackCWD
- corePackageDbs =
- Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared)
+ compilerAndPlatform =
+ fmap
+ (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform))
+ toolchains
withRepoCtx :: (RepoContext -> IO a) -> IO a
withRepoCtx =
@@ -875,8 +963,8 @@ rebuildInstallPlan
--
phaseElaboratePlan
:: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
- -> Maybe PkgConfigDb
+ -> Staged Toolchain
+ -> Staged (Maybe PkgConfigDb)
-> SolverInstallPlan
-> [PackageSpecifier (SourcePackage (PackageLocation loc))]
-> Rebuild
@@ -891,7 +979,7 @@ rebuildInstallPlan
, projectConfigSpecificPackage
, projectConfigBuildOnly
}
- (compiler, platform, progdb)
+ toolchains
pkgConfigDB
solverPlan
localPackages = do
@@ -904,15 +992,16 @@ rebuildInstallPlan
(packageLocationsSignature solverPlan)
$ getPackageSourceHashes verbosity withRepoCtx solverPlan
- defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
- let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared)
- (elaboratedPlan, elaboratedShared) <-
- liftIO . runLogProgress verbosity $
+ installDirs <-
+ for toolchains $ \t -> do
+ defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t)
+ return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared)
+
+ liftIO $ runLogProgress verbosity $ do
+ (elaboratedPlan, elaboratedShared) <-
elaborateInstallPlan
verbosity
- platform
- compiler
- progdb
+ toolchains
pkgConfigDB
distDirLayout
cabalStoreDirLayout
@@ -924,14 +1013,17 @@ rebuildInstallPlan
projectConfigAllPackages
projectConfigLocalPackages
(getMapMappend projectConfigSpecificPackage)
- let instantiatedPlan =
- instantiateInstallPlan
- cabalStoreDirLayout
- installDirs
- elaboratedShared
- elaboratedPlan
- liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan)
- return (instantiatedPlan, elaboratedShared)
+
+ instantiatedPlan <-
+ instantiateInstallPlan
+ cabalStoreDirLayout
+ installDirs
+ elaboratedShared
+ elaboratedPlan
+
+ infoProgress $ text "Elaborated install plan:" $$ text (showElaboratedInstallPlan instantiatedPlan)
+
+ return (instantiatedPlan, elaboratedShared)
where
withRepoCtx :: (RepoContext -> IO a) -> IO a
withRepoCtx =
@@ -971,11 +1063,7 @@ rebuildInstallPlan
-> Rebuild ElaboratedInstallPlan
phaseImprovePlan elaboratedPlan elaboratedShared = do
liftIO $ debug verbosity "Improving the install plan..."
- storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler
- let improvedPlan =
- improveInstallPlanWithInstalledPackages
- storePkgIdSet
- elaboratedPlan
+ improvedPlan <- liftIO $ InstallPlan.installedM canBeImproved elaboratedPlan
liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan)
-- TODO: [nice to have] having checked which packages from the store
-- we're using, it may be sensible to sanity check those packages
@@ -983,7 +1071,9 @@ rebuildInstallPlan
-- matches up as expected, e.g. no dangling deps, files deleted.
return improvedPlan
where
- compiler = pkgConfigCompiler elaboratedShared
+ canBeImproved pkg = do
+ let Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains elaboratedShared) (elabStage pkg)
+ doesStoreEntryExist cabalStoreDirLayout toolchainCompiler (installedUnitId pkg)
-- | If a 'PackageSpecifier' refers to a single package, return Just that
-- package.
@@ -1036,44 +1126,28 @@ programsMonitorFiles progdb =
(programPath prog)
]
--- | Select the bits of a 'ProgramDb' to monitor for value changes.
--- Use 'programsMonitorFiles' for the files to monitor.
-programDbSignature :: ProgramDb -> [ConfiguredProgram]
-programDbSignature progdb =
- [ prog
- { programMonitorFiles = []
- , programOverrideEnv =
- filter
- ((/= "PATH") . fst)
- (programOverrideEnv prog)
- }
- | prog <- configuredPrograms progdb
- ]
-
getInstalledPackages
:: Verbosity
- -> Compiler
- -> ProgramDb
- -> Platform
- -> PackageDBStackCWD
+ -> Toolchain
-> Rebuild InstalledPackageIndex
-getInstalledPackages verbosity compiler progdb platform packagedbs = do
- monitorFiles . map monitorFileOrDirectory
+getInstalledPackages verbosity Toolchain{..} = do
+ monitorFiles
+ . map monitorFileOrDirectory
=<< liftIO
( IndexUtils.getInstalledPackagesMonitorFiles
verbosity
- compiler
+ toolchainCompiler
Nothing -- use ambient working directory
- (coercePackageDBStack packagedbs)
- progdb
- platform
+ (coercePackageDBStack toolchainPackageDBs)
+ toolchainProgramDb
+ toolchainPlatform
)
liftIO $
IndexUtils.getInstalledPackages
verbosity
- compiler
- packagedbs
- progdb
+ toolchainCompiler
+ toolchainPackageDBs
+ toolchainProgramDb
{-
--TODO: [nice to have] use this but for sanity / consistency checking
@@ -1101,9 +1175,10 @@ getSourcePackages
getSourcePackages verbosity withRepoCtx idxState activeRepos = do
(sourcePkgDbWithTIS, repos) <-
liftIO $
- withRepoCtx $ \repoctx -> do
- sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos
- return (sourcePkgDbWithTIS, repoContextRepos repoctx)
+ withRepoCtx $
+ \repoctx -> do
+ sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos
+ return (sourcePkgDbWithTIS, repoContextRepos repoctx)
traverse_ needIfExists
. IndexUtils.getSourcePackagesMonitorFiles
@@ -1226,8 +1301,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
-- the hashes for the packages
--
hashesFromRepoMetadata <-
- Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions
- fmap (Map.fromList . concat) $
+ Sec.uncheckClientErrors $
+ fmap (Map.fromList . concat) $ -- TODO: [code cleanup] wrap in our own exceptions
sequence
-- Reading the repo index is expensive so we group the packages by repo
[ repoContextWithSecureRepo repoctx repo $ \secureRepo ->
@@ -1305,30 +1380,24 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
planPackages
:: Verbosity
- -> Compiler
- -> Platform
-> SolverSettings
- -> InstalledPackageIndex
+ -> Staged (CompilerInfo, Platform)
+ -> Staged (Maybe PkgConfigDb)
+ -> Staged InstalledPackageIndex
-> SourcePackageDb
- -> Maybe PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> Map PackageName (Map OptionalStanza Bool)
-> Progress String String SolverInstallPlan
planPackages
verbosity
- comp
- platform
SolverSettings{..}
- installedPkgIndex
- sourcePkgDb
- pkgConfigDB
+ toolchains
+ pkgConfigDbs
+ installedPkgs
+ sourcePkgs
localPackages
pkgStanzasEnable =
- resolveDependencies
- platform
- (compilerInfo comp)
- pkgConfigDB
- resolverParams
+ resolveDependencies toolchains pkgConfigDbs installedPkgs resolverParams
where
-- TODO: [nice to have] disable multiple instances restriction in
-- the solver, but then make sure we can cope with that in the
@@ -1368,13 +1437,18 @@ planPackages
. removeLowerBounds solverSettingAllowOlder
. removeUpperBounds solverSettingAllowNewer
- . addDefaultSetupDependencies
- ( mkDefaultSetupDeps comp platform
- . PD.packageDescription
- . srcpkgDescription
- )
- . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint
- . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint
+ --
+ -- TODO: These need to be per compiler. We should be able to do that
+ -- when we can use the stage as a solver scope
+ --
+ -- . addDefaultSetupDependencies
+ -- ( mkDefaultSetupDeps compiler platform
+ -- . PD.packageDescription
+ -- . srcpkgDescription
+ -- )
+ -- . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint
+ -- . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint
+ --
. addPreferences
-- preferences from the config file or command line
[ PackageVersionPreference name ver
@@ -1398,7 +1472,9 @@ planPackages
, not (null stanzas)
]
. addConstraints
- -- enable stanza constraints where the user asked to enable
+ -- Enable stanza constraints where the user asked to enable
+ -- Only applies to the host stage.
+ -- TODO: Disable test and bench for build stage packages.
[ LabeledPackageConstraint
( PackageConstraint
(scopeToplevel pkgname)
@@ -1447,84 +1523,9 @@ planPackages
-- Note: we don't use the standardInstallPolicy here, since that uses
-- its own addDefaultSetupDependencies that is not appropriate for us.
basicInstallPolicy
- installedPkgIndex
- sourcePkgDb
+ sourcePkgs
localPackages
- -- While we can talk to older Cabal versions (we need to be able to
- -- do so for custom Setup scripts that require older Cabal lib
- -- versions), we have problems talking to some older versions that
- -- don't support certain features.
- --
- -- For example, Cabal-1.16 and older do not know about build targets.
- -- Even worse, 1.18 and older only supported the --constraint flag
- -- with source package ids, not --dependency with installed package
- -- ids. That is bad because we cannot reliably select the right
- -- dependencies in the presence of multiple instances (i.e. the
- -- store). See issue #3932. So we require Cabal 1.20 as a minimum.
- --
- -- Moreover, lib:Cabal generally only supports the interface of
- -- current and past compilers; in fact recent lib:Cabal versions
- -- will warn when they encounter a too new or unknown GHC compiler
- -- version (c.f. #415). To avoid running into unsupported
- -- configurations we encode the compatibility matrix as lower
- -- bounds on lib:Cabal here (effectively corresponding to the
- -- respective major Cabal version bundled with the respective GHC
- -- release).
- --
- -- GHC 9.2 needs Cabal >= 3.6
- -- GHC 9.0 needs Cabal >= 3.4
- -- GHC 8.10 needs Cabal >= 3.2
- -- GHC 8.8 needs Cabal >= 3.0
- -- GHC 8.6 needs Cabal >= 2.4
- -- GHC 8.4 needs Cabal >= 2.2
- -- GHC 8.2 needs Cabal >= 2.0
- -- GHC 8.0 needs Cabal >= 1.24
- -- GHC 7.10 needs Cabal >= 1.22
- --
- -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is
- -- the absolute lower bound)
- --
- -- TODO: long-term, this compatibility matrix should be
- -- stored as a field inside 'Distribution.Compiler.Compiler'
- setupMinCabalVersionConstraint
- | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12]
- | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10]
- | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8]
- | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6]
- | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4]
- | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2]
- | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0]
- | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4]
- | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2]
- | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0]
- | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24]
- | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22]
- | otherwise = mkVersion [1, 20]
- where
- isGHC = compFlav `elem` [GHC, GHCJS]
- compFlav = compilerFlavor comp
- compVer = compilerVersion comp
-
- -- As we can't predict the future, we also place a global upper
- -- bound on the lib:Cabal version we know how to interact with:
- --
- -- The upper bound is computed by incrementing the current major
- -- version twice in order to allow for the current version, as
- -- well as the next adjacent major version (one of which will not
- -- be released, as only "even major" versions of Cabal are
- -- released to Hackage or bundled with proper GHC releases).
- --
- -- For instance, if the current version of cabal-install is an odd
- -- development version, e.g. Cabal-2.1.0.0, then we impose an
- -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a
- -- stable/release even version, e.g. Cabal-2.2.1.0, the upper
- -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility
- -- when dealing with development snapshots of Cabal and cabal-install.
- --
- setupMaxCabalVersionConstraint =
- alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion
-
------------------------------------------------------------------------------
-- * Install plan post-processing
@@ -1630,16 +1631,14 @@ planPackages
-- matching that of the classic @cabal install --user@ or @--global@
elaborateInstallPlan
:: Verbosity
- -> Platform
- -> Compiler
- -> ProgramDb
- -> Maybe PkgConfigDb
+ -> Staged Toolchain
+ -> Staged (Maybe PkgConfigDb)
-> DistDirLayout
-> StoreDirLayout
-> SolverInstallPlan
-> [PackageSpecifier (SourcePackage (PackageLocation loc))]
-> Map PackageId PackageSourceHash
- -> InstallDirs.InstallDirTemplates
+ -> Staged InstallDirs.InstallDirTemplates
-> ProjectConfigShared
-> PackageConfig
-> PackageConfig
@@ -1647,9 +1646,7 @@ elaborateInstallPlan
-> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)
elaborateInstallPlan
verbosity
- platform
- compiler
- compilerprogdb
+ toolchains
pkgConfigDB
distDirLayout@DistDirLayout{..}
storeDirLayout@StoreDirLayout{storePackageDBStack}
@@ -1666,9 +1663,7 @@ elaborateInstallPlan
where
elaboratedSharedConfig =
ElaboratedSharedConfig
- { pkgConfigPlatform = platform
- , pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = compilerprogdb
+ { pkgConfigToolchains = toolchains
, pkgConfigReplOptions = mempty
}
@@ -1688,13 +1683,12 @@ elaborateInstallPlan
)
f _ = Nothing
- elaboratedInstallPlan
- :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)
+ elaboratedInstallPlan :: LogProgress ElaboratedInstallPlan
elaboratedInstallPlan =
flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
case planpkg of
SolverInstallPlan.PreExisting pkg ->
- return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]
+ return [InstallPlan.PreExisting (WithStage (instSolverStage pkg) (instSolverPkgIPI pkg))]
SolverInstallPlan.Configured pkg ->
let inplace_doc
| shouldBuildInplaceOnly pkg = text "inplace"
@@ -1710,344 +1704,400 @@ elaborateInstallPlan
-- NB: We don't INSTANTIATE packages at this point. That's
-- a post-pass. This makes it simpler to compute dependencies.
elaborateSolverToComponents
- :: (SolverId -> [ElaboratedPlanPackage])
+ :: HasCallStack
+ => (SolverId -> [ElaboratedPlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> LogProgress [ElaboratedConfiguredPackage]
- elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) =
- case mkComponentsGraph (elabEnabledSpec elab0) pd of
- Right g -> do
- let src_comps = componentsGraphToList g
- infoProgress $
- hang
- (text "Component graph for" <+> pretty pkgid <<>> colon)
- 4
- (dispComponentsWithDeps src_comps)
- (_, comps) <-
- mapAccumM
- buildComponent
- (Map.empty, Map.empty, Map.empty)
- (map fst src_comps)
- let whyNotPerComp = why_not_per_component src_comps
- case NE.nonEmpty whyNotPerComp of
- Nothing -> do
- elaborationWarnings
- return comps
- Just notPerCompReasons -> do
- checkPerPackageOk comps notPerCompReasons
- pkgComp <-
- elaborateSolverToPackage
- notPerCompReasons
- spkg
- g
- (comps ++ maybeToList setupComponent)
- return [pkgComp]
- Left cns ->
- dieProgress $
- hang
- (text "Dependency cycle between the following components:")
- 4
- (vcat (map (text . componentNameStanza) cns))
- where
- bt = PD.buildType (elabPkgDescription elab0)
- -- You are eligible to per-component build if this list is empty
- why_not_per_component g =
- cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag
- where
- -- Custom and Hooks are not implemented. Implementing
- -- per-component builds with Custom would require us to create a
- -- new 'ElabSetup' type, and teach all of the code paths how to
- -- handle it.
- -- Once you've implemented this, swap it for the code below.
- cuz_buildtype =
- case bt of
- PD.Configure -> []
- -- Configure is supported, but we only support configuring the
- -- main library in cabal. Other components will need to depend
- -- on the main library for configured data.
- PD.Custom -> [CuzBuildType CuzCustomBuildType]
- PD.Hooks -> [CuzBuildType CuzHooksBuildType]
- PD.Make -> [CuzBuildType CuzMakeBuildType]
- PD.Simple -> []
- -- cabal-format versions prior to 1.8 have different build-depends semantics
- -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8
- -- see, https://github.com/haskell/cabal/issues/4121
- cuz_spec
- | PD.specVersion pd >= CabalSpecV1_8 = []
- | otherwise = [CuzCabalSpecVersion]
- -- In the odd corner case that a package has no components at all
- -- then keep it as a whole package, since otherwise it turns into
- -- 0 component graph nodes and effectively vanishes. We want to
- -- keep it around at least for error reporting purposes.
- cuz_length
- | length g > 0 = []
- | otherwise = [CuzNoBuildableComponents]
- -- For ease of testing, we let per-component builds be toggled
- -- at the top level
- cuz_flag
- | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) =
- []
- | otherwise = [CuzDisablePerComponent]
-
- -- \| Sometimes a package may make use of features which are only
- -- supported in per-package mode. If this is the case, we should
- -- give an error when this occurs.
- checkPerPackageOk comps reasons = do
- let is_sublib (CLibName (LSubLibName _)) = True
- is_sublib _ = False
- when (any (matchElabPkg is_sublib) comps) $
+ elaborateSolverToComponents
+ mapDep
+ solverPkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} =
+ case mkComponentsGraph (elabEnabledSpec elab0) pd of
+ Left cns ->
dieProgress $
- text "Internal libraries only supported with per-component builds."
- $$ text "Per-component builds were disabled because"
- <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons)
- -- TODO: Maybe exclude Backpack too
-
- (elab0, elaborationWarnings) = elaborateSolverToCommon spkg
- pkgid = elabPkgSourceId elab0
- pd = elabPkgDescription elab0
-
- -- TODO: This is just a skeleton to get elaborateSolverToPackage
- -- working correctly
- -- TODO: When we actually support building these components, we
- -- have to add dependencies on this from all other components
- setupComponent :: Maybe ElaboratedConfiguredPackage
- setupComponent
- | bt `elem` [PD.Custom, PD.Hooks] =
- Just
- elab0
- { elabModuleShape = emptyModuleShape
- , elabUnitId = notImpl "elabUnitId"
- , elabComponentId = notImpl "elabComponentId"
- , elabLinkedInstantiatedWith = Map.empty
- , elabInstallDirs = notImpl "elabInstallDirs"
- , elabPkgOrComp = ElabComponent (ElaboratedComponent{..})
- }
- | otherwise =
- Nothing
- where
- compSolverName = CD.ComponentSetup
- compComponentName = Nothing
-
- dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0
-
- compLibDependencies =
- -- MP: No idea what this function does
- map (\cid -> (configuredId cid, False)) dep_pkgs
- compLinkedLibDependencies = notImpl "compLinkedLibDependencies"
- compOrderLibDependencies = notImpl "compOrderLibDependencies"
-
- -- Not supported:
- compExeDependencies :: [a]
- compExeDependencies = []
-
- compExeDependencyPaths :: [a]
- compExeDependencyPaths = []
-
- compPkgConfigDependencies :: [a]
- compPkgConfigDependencies = []
-
- notImpl f =
- error $
- "Distribution.Client.ProjectPlanning.setupComponent: "
- ++ f
- ++ " not implemented yet"
-
- buildComponent
- :: ( ConfiguredComponentMap
- , LinkedComponentMap
- , Map ComponentId FilePath
- )
- -> Cabal.Component
- -> LogProgress
- ( ( ConfiguredComponentMap
- , LinkedComponentMap
- , Map ComponentId FilePath
+ hang
+ (text "Dependency cycle between the following components:")
+ 4
+ (vcat (map (text . componentNameStanza) cns))
+ Right g -> do
+ let src_comps = componentsGraphToList g
+
+ infoProgress $
+ hang
+ (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured solverPkg)))
+ 4
+ (dispComponentsWithDeps src_comps)
+
+ (_, comps) <-
+ mapAccumM
+ buildComponent
+ (Map.empty, Map.empty, Map.empty)
+ (map fst src_comps)
+
+ let whyNotPerComp = why_not_per_component src_comps
+
+ case NE.nonEmpty whyNotPerComp of
+ Nothing ->
+ return comps
+ Just notPerCompReasons -> do
+ checkPerPackageOk comps notPerCompReasons
+ pkgComp <-
+ elaborateSolverToPackage
+ notPerCompReasons
+ solverPkg
+ g
+ (comps ++ maybeToList setupComponent)
+ return [pkgComp]
+ where
+ bt = PD.buildType (elabPkgDescription elab0)
+
+ -- You are eligible to per-component build if this list is empty
+ why_not_per_component g =
+ cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag
+ where
+ -- Custom and Hooks are not implemented. Implementing
+ -- per-component builds with Custom would require us to create a
+ -- new 'ElabSetup' type, and teach all of the code paths how to
+ -- handle it.
+ -- Once you've implemented this, swap it for the code below.
+ cuz_buildtype =
+ case bt of
+ PD.Configure -> []
+ -- Configure is supported, but we only support configuring the
+ -- main library in cabal. Other components will need to depend
+ -- on the main library for configured data.
+ PD.Custom -> [CuzBuildType CuzCustomBuildType]
+ PD.Hooks -> [CuzBuildType CuzHooksBuildType]
+ PD.Make -> [CuzBuildType CuzMakeBuildType]
+ PD.Simple -> []
+ -- cabal-format versions prior to 1.8 have different build-depends semantics
+ -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8
+ -- see, https://github.com/haskell/cabal/issues/4121
+ cuz_spec
+ | PD.specVersion pd >= CabalSpecV1_8 = []
+ | otherwise = [CuzCabalSpecVersion]
+ -- In the odd corner case that a package has no components at all
+ -- then keep it as a whole package, since otherwise it turns into
+ -- 0 component graph nodes and effectively vanishes. We want to
+ -- keep it around at least for error reporting purposes.
+ cuz_length
+ | length g > 0 = []
+ | otherwise = [CuzNoBuildableComponents]
+ -- For ease of testing, we let per-component builds be toggled
+ -- at the top level
+ cuz_flag
+ | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) =
+ []
+ | otherwise = [CuzDisablePerComponent]
+
+ -- \| Sometimes a package may make use of features which are only
+ -- supported in per-package mode. If this is the case, we should
+ -- give an error when this occurs.
+ checkPerPackageOk comps reasons = do
+ let is_sublib (CLibName (LSubLibName _)) = True
+ is_sublib _ = False
+ when (any (matchElabPkg is_sublib) comps) $
+ dieProgress $
+ text "Internal libraries only supported with per-component builds."
+ $$ text "Per-component builds were disabled because"
+ <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons)
+ -- TODO: Maybe exclude Backpack too
+
+ (elab0, _) = elaborateSolverToCommon solverPkg
+ pkgid = elabPkgSourceId elab0
+ pd = elabPkgDescription elab0
+
+ -- TODO: This is just a skeleton to get elaborateSolverToPackage
+ -- working correctly
+ -- TODO: When we actually support building these components, we
+ -- have to add dependencies on this from all other components
+ setupComponent :: Maybe ElaboratedConfiguredPackage
+ setupComponent
+ | bt `elem` [PD.Custom, PD.Hooks] =
+ Just
+ elab0
+ { elabModuleShape = emptyModuleShape
+ , elabUnitId = notImpl "elabUnitId"
+ , elabComponentId = notImpl "elabComponentId"
+ , elabInstallDirs = notImpl "elabInstallDirs"
+ , elabPkgOrComp =
+ ElabComponent
+ ( ElaboratedComponent
+ { compSolverName = CD.ComponentSetup
+ , compComponentName = Nothing
+ , compLibDependencies =
+ [ (configuredId cid, False)
+ | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep
+ ]
+ , compLinkedLibDependencies = notImpl "compLinkedLibDependencies"
+ , compOrderLibDependencies = notImpl "compOrderLibDependencies"
+ , -- Not supported:
+ compExeDependencies = mempty
+ , compExeDependencyPaths = mempty
+ , compPkgConfigDependencies = mempty
+ , compInstantiatedWith = mempty
+ , compLinkedInstantiatedWith = Map.empty
+ }
+ )
+ }
+ | otherwise =
+ Nothing
+ where
+ notImpl f =
+ error $
+ "Distribution.Client.ProjectPlanning.setupComponent: "
+ ++ f
+ ++ " not implemented yet"
+
+ -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope)
+ buildComponent
+ :: HasCallStack
+ => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId))
+ , Map ComponentId (OpenUnitId, ModuleShape)
+ , Map ComponentId FilePath
+ )
+ -> Cabal.Component
+ -> LogProgress
+ ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId))
+ , Map ComponentId (OpenUnitId, ModuleShape)
+ , Map ComponentId FilePath
+ )
+ , ElaboratedConfiguredPackage
)
- , ElaboratedConfiguredPackage
+ buildComponent (cc_map, lc_map, exe_map) comp =
+ addProgressCtx
+ ( text "In the stanza"
+ <+> quotes (text (componentNameStanza cname))
)
- buildComponent (cc_map, lc_map, exe_map) comp =
- addProgressCtx
- ( text "In the stanza"
- <+> quotes (text (componentNameStanza cname))
- )
- $ do
- -- 1. Configure the component, but with a place holder ComponentId.
- cc0 <-
- toConfiguredComponent
- pd
- (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later")
- (Map.unionWith Map.union external_lib_cc_map cc_map)
- (Map.unionWith Map.union external_exe_cc_map cc_map)
- comp
-
- let do_ cid =
- let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid
- in (cid', False) -- filled in later in pruneInstallPlanPhase2)
- -- 2. Read out the dependencies from the ConfiguredComponent cc0
- let compLibDependencies =
- -- Nub because includes can show up multiple times
- ordNub
- ( map
- (\cid -> do_ cid)
- (cc_includes cc0)
- )
- compExeDependencies =
- map
- annotatedIdToConfiguredId
- (cc_exe_deps cc0)
- compExeDependencyPaths =
- [ (annotatedIdToConfiguredId aid', path)
- | aid' <- cc_exe_deps cc0
- , Just paths <- [Map.lookup (ann_id aid') exe_map1]
- , path <- paths
- ]
- elab_comp = ElaboratedComponent{..}
-
- -- 3. Construct a preliminary ElaboratedConfiguredPackage,
- -- and use this to compute the component ID. Fix up cc_id
- -- correctly.
- let elab1 =
- elab0
- { elabPkgOrComp = ElabComponent elab_comp
+ $ do
+ let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map
+ -- TODO: is cc_map correct here?
+ exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map
+
+ -- 1. Configure the component, but with a place holder ComponentId.
+ infoProgress $
+ hang (text "configuring component" <+> pretty cname) 4 $
+ vcat
+ [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map))
+ , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map))
+ ]
+
+ cc0 <-
+ toConfiguredComponent
+ pd
+ (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later")
+ lib_dep_map
+ exe_dep_map
+ comp
+
+ let do_ cid =
+ let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid
+ in (cid', False) -- filled in later in pruneInstallPlanPhase2)
+
+ -- 2. Read out the dependencies from the ConfiguredComponent cc0
+ let compLibDependencies =
+ -- Nub because includes can show up multiple times
+ ordNub
+ ( map
+ (\cid -> do_ cid)
+ (cc_includes cc0)
+ )
+
+ compExeDependencies :: [WithStage ConfiguredId]
+ compExeDependencies =
+ -- External
+ [ WithStage (stageOf pkg) confId
+ | pkg <- external_exe_dep_pkgs
+ , let confId = configuredId pkg
+ , -- only executables
+ Just (CExeName _) <- [confCompName confId]
+ , confSrcId confId /= pkgid
+ ]
+ <>
+ -- Internal, assume the same stage
+ [ WithStage solverPkgStage confId
+ | aid <- cc_exe_deps cc0
+ , let confId = annotatedIdToConfiguredId aid
+ , confSrcId confId == pkgid
+ ]
+
+ compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)]
+ compExeDependencyPaths =
+ -- External
+ [ (WithStage (stageOf pkg) confId, path)
+ | pkg <- external_exe_dep_pkgs
+ , let confId = configuredId pkg
+ , confSrcId confId /= pkgid
+ , -- only executables
+ Just (CExeName _) <- [confCompName confId]
+ , path <- planPackageExePaths pkg
+ ]
+ <>
+ -- Internal, assume the same stage
+ [ (WithStage solverPkgStage confId, path)
+ | aid <- cc_exe_deps cc0
+ , let confId = annotatedIdToConfiguredId aid
+ , confSrcId confId == pkgid
+ , Just paths <- [Map.lookup (ann_id aid) exe_map1]
+ , path <- paths
+ ]
+
+ elab_comp =
+ ElaboratedComponent
+ { compSolverName
+ , compComponentName
+ , compLibDependencies
+ , compExeDependencies
+ , compPkgConfigDependencies
+ , compExeDependencyPaths
+ , compInstantiatedWith = Map.empty
+ , compLinkedInstantiatedWith = Map.empty
+ , -- filled later (in step 5)
+ compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"
+ , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies"
+ }
+
+ -- 3. Construct a preliminary ElaboratedConfiguredPackage,
+ -- and use this to compute the component ID. Fix up cc_id
+ -- correctly.
+ let elab1 =
+ elab0
+ { elabPkgOrComp = ElabComponent elab_comp
+ }
+
+ -- This is where the component id is computed.
+ cid = case elabBuildStyle elab0 of
+ BuildInplaceOnly{} ->
+ mkComponentId $
+ case Cabal.componentNameString cname of
+ Nothing -> prettyShow pkgid
+ Just n -> prettyShow pkgid ++ "-" ++ prettyShow n
+ BuildAndInstall ->
+ hashedInstalledPackageId
+ ( packageHashInputs
+ elaboratedSharedConfig
+ elab1 -- knot tied
+ )
+
+ cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)}
+
+ -- 4. Perform mix-in linking
+ let lookup_uid def_uid =
+ case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of
+ Just full -> full
+ Nothing -> error ("lookup_uid: " ++ prettyShow def_uid)
+ lc_dep_map = Map.union external_lc_map lc_map
+ lc <-
+ toLinkedComponent
+ verbosity
+ False
+ -- \^ whether there are any "promised" package dependencies which we won't find already installed
+ lookup_uid
+ -- \^ full db
+ (elabPkgSourceId elab0)
+ -- \^ the source package id
+ lc_dep_map
+ -- \^ linked component map
+ cc
+ -- \^ configured component
+
+ -- NB: elab is setup to be the correct form for an
+ -- indefinite library, or a definite library with no holes.
+ -- We will modify it in 'instantiateInstallPlan' to handle
+ -- instantiated packages.
+
+ -- 5. Construct the final ElaboratedConfiguredPackage
+ let
+ elab2 =
+ elab1
+ { elabModuleShape = lc_shape lc
+ , elabUnitId = abstractUnitId (lc_uid lc)
+ , elabComponentId = lc_cid lc
+ , elabPkgOrComp =
+ ElabComponent $
+ elab_comp
+ { compLinkedLibDependencies =
+ ordNub (map ci_id (lc_includes lc))
+ , compOrderLibDependencies =
+ ordNub
+ ( map
+ (abstractUnitId . ci_id)
+ (lc_includes lc ++ lc_sig_includes lc)
+ )
+ , compLinkedInstantiatedWith =
+ Map.fromList (lc_insts lc)
+ }
}
- cid = case elabBuildStyle elab0 of
- BuildInplaceOnly{} ->
- mkComponentId $
- prettyShow pkgid
- ++ "-inplace"
- ++ ( case Cabal.componentNameString cname of
- Nothing -> ""
- Just s -> "-" ++ prettyShow s
- )
- BuildAndInstall ->
- hashedInstalledPackageId
- ( packageHashInputs
+ elab =
+ elab2
+ { elabInstallDirs =
+ computeInstallDirs
+ storeDirLayout
+ defaultInstallDirs
elaboratedSharedConfig
- elab1 -- knot tied
- )
- cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)}
- infoProgress $ dispConfiguredComponent cc
-
- -- 4. Perform mix-in linking
- let lookup_uid def_uid =
- case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of
- Just full -> full
- Nothing -> error ("lookup_uid: " ++ prettyShow def_uid)
- lc <-
- toLinkedComponent
- verbosity
- False
- lookup_uid
- (elabPkgSourceId elab0)
- (Map.union external_lc_map lc_map)
- cc
- infoProgress $ dispLinkedComponent lc
- -- NB: elab is setup to be the correct form for an
- -- indefinite library, or a definite library with no holes.
- -- We will modify it in 'instantiateInstallPlan' to handle
- -- instantiated packages.
-
- -- 5. Construct the final ElaboratedConfiguredPackage
- let
- elab2 =
- elab1
- { elabModuleShape = lc_shape lc
- , elabUnitId = abstractUnitId (lc_uid lc)
- , elabComponentId = lc_cid lc
- , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc)
- , elabPkgOrComp =
- ElabComponent $
- elab_comp
- { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc))
- , compOrderLibDependencies =
- ordNub
- ( map
- (abstractUnitId . ci_id)
- (lc_includes lc ++ lc_sig_includes lc)
- )
- }
- }
- elab =
- elab2
- { elabInstallDirs =
- computeInstallDirs
- storeDirLayout
- defaultInstallDirs
- elaboratedSharedConfig
- elab2
- }
+ elab2
+ }
- -- 6. Construct the updated local maps
- let cc_map' = extendConfiguredComponentMap cc cc_map
- lc_map' = extendLinkedComponentMap lc lc_map
- exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map
+ -- 6. Construct the updated local maps
+ let cc_map' = extendConfiguredComponentMap cc cc_map
+ lc_map' = extendLinkedComponentMap lc lc_map
+ exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map
- return ((cc_map', lc_map', exe_map'), elab)
- where
- compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"
- compOrderLibDependencies = error "buildComponent: compOrderLibDependencies"
-
- cname = Cabal.componentName comp
- compComponentName = Just cname
- compSolverName = CD.componentNameToComponent cname
-
- -- NB: compLinkedLibDependencies and
- -- compOrderLibDependencies are defined when we define
- -- 'elab'.
- external_lib_dep_sids = CD.select (== compSolverName) deps0
- external_exe_dep_sids = CD.select (== compSolverName) exe_deps0
-
- external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids
-
- -- Combine library and build-tool dependencies, for backwards
- -- compatibility (See issue #5412 and the documentation for
- -- InstallPlan.fromSolverInstallPlan), but prefer the versions
- -- specified as build-tools.
- external_exe_dep_pkgs =
- concatMap mapDep $
- ordNubBy (pkgName . packageId) $
- external_exe_dep_sids ++ external_lib_dep_sids
-
- external_exe_map =
- Map.fromList $
- [ (getComponentId pkg, paths)
- | pkg <- external_exe_dep_pkgs
- , let paths = planPackageExePaths pkg
+ return ((cc_map', lc_map', exe_map'), elab)
+ where
+ cname = Cabal.componentName comp
+ compComponentName = Just cname
+ compSolverName = CD.componentNameToComponent cname
+
+ -- External dependencies. I.e. dependencies of the component on components of other packages.
+ external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps
+
+ external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps
+
+ external_exe_map =
+ Map.fromList $
+ [ (getComponentId pkg, planPackageExePaths pkg)
+ | pkg <- external_exe_dep_pkgs
+ ]
+
+ exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map
+
+ external_lib_cc_map =
+ Map.fromListWith Map.union $
+ map mkCCMapping external_lib_dep_pkgs
+
+ external_exe_cc_map =
+ Map.fromListWith Map.union $
+ map mkCCMapping external_exe_dep_pkgs
+
+ external_lc_map =
+ Map.fromList $
+ map mkShapeMapping $
+ external_lib_dep_pkgs ++ external_exe_dep_pkgs
+
+ compPkgConfigDependencies =
+ [ ( pn
+ , fromMaybe
+ ( error $
+ "compPkgConfigDependencies: impossible! "
+ ++ prettyShow pn
+ ++ " from "
+ ++ prettyShow (elabPkgSourceId elab0)
+ )
+ (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn)
+ )
+ | PkgconfigDependency pn _ <-
+ PD.pkgconfigDepends
+ (Cabal.componentBuildInfo comp)
]
- exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map
-
- external_lib_cc_map =
- Map.fromListWith Map.union $
- map mkCCMapping external_lib_dep_pkgs
- external_exe_cc_map =
- Map.fromListWith Map.union $
- map mkCCMapping external_exe_dep_pkgs
- external_lc_map =
- Map.fromList $
- map mkShapeMapping $
- external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids
-
- compPkgConfigDependencies =
- [ ( pn
- , fromMaybe
- ( error $
- "compPkgConfigDependencies: impossible! "
- ++ prettyShow pn
- ++ " from "
- ++ prettyShow (elabPkgSourceId elab0)
- )
- (pkgConfigDB >>= \db -> pkgConfigDbPkgVersion db pn)
- )
- | PkgconfigDependency pn _ <-
- PD.pkgconfigDepends
- (Cabal.componentBuildInfo comp)
- ]
- inplace_bin_dir elab =
- binDirectoryFor
- distDirLayout
- elaboratedSharedConfig
- elab
- $ maybe "" prettyShow (Cabal.componentNameString cname)
+ inplace_bin_dir elab =
+ binDirectoryFor
+ distDirLayout
+ elaboratedSharedConfig
+ elab
+ $ case Cabal.componentNameString cname of
+ Just n -> prettyShow n
+ Nothing -> ""
-- \| Given a 'SolverId' referencing a dependency on a library, return
-- the 'ElaboratedPlanPackage' corresponding to the library. This
@@ -2098,13 +2148,7 @@ elaborateInstallPlan
-> LogProgress ElaboratedConfiguredPackage
elaborateSolverToPackage
pkgWhyNotPerComponent
- pkg@( SolverPackage
- (SourcePackage pkgid _gpd _srcloc _descOverride)
- _flags
- _stanzas
- _deps0
- _exe_deps0
- )
+ solverPkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}}
compGraph
comps = do
-- Knot tying: the final elab includes the
@@ -2113,15 +2157,17 @@ elaborateInstallPlan
elaborationWarnings
return elab
where
- (elab0@ElaboratedConfiguredPackage{..}, elaborationWarnings) =
- elaborateSolverToCommon pkg
+ (elab0@ElaboratedConfiguredPackage
+ { elabPkgSourceHash
+ , elabStanzasRequested
+ , elabStage
+ }, elaborationWarnings) = elaborateSolverToCommon solverPkg
elab1 =
elab0
{ elabUnitId = newSimpleUnitId pkgInstalledId
, elabComponentId = pkgInstalledId
- , elabLinkedInstantiatedWith = Map.empty
- , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..}
+ , elabPkgOrComp = ElabPackage elabPkg
, elabModuleShape = modShape
}
@@ -2142,8 +2188,8 @@ elaborateInstallPlan
(find (matchElabPkg (== (CLibName LMainLibName))) comps)
pkgInstalledId
- | shouldBuildInplaceOnly pkg =
- mkComponentId (prettyShow pkgid ++ "-inplace")
+ | shouldBuildInplaceOnly solverPkg =
+ mkComponentId (prettyShow srcpkgPackageId)
| otherwise =
assert (isJust elabPkgSourceHash) $
hashedInstalledPackageId
@@ -2154,34 +2200,44 @@ elaborateInstallPlan
-- Need to filter out internal dependencies, because they don't
-- correspond to anything real anymore.
- isExt confid = confSrcId confid /= pkgid
- filterExt = filter isExt
-
- filterExt' :: [(ConfiguredId, a)] -> [(ConfiguredId, a)]
- filterExt' = filter (isExt . fst)
-
- pkgLibDependencies =
- buildComponentDeps (filterExt' . compLibDependencies)
- pkgExeDependencies =
- buildComponentDeps (filterExt . compExeDependencies)
- pkgExeDependencyPaths =
- buildComponentDeps (filterExt' . compExeDependencyPaths)
-
- -- TODO: Why is this flat?
- pkgPkgConfigDependencies =
- CD.flatDeps $ buildComponentDeps compPkgConfigDependencies
+ isExternal confid = confSrcId confid /= srcpkgPackageId
+ isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId
+
+ elabPkg =
+ ElaboratedPackage
+ { pkgStage = elabStage
+ , pkgInstalledId
+ , pkgLibDependencies = buildComponentDeps (filter (isExternal . fst) . compLibDependencies)
+ , pkgDependsOnSelfLib
+ , pkgExeDependencies = buildComponentDeps (filter isExternal' . compExeDependencies)
+ , pkgExeDependencyPaths = buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths)
+ , -- Why is this flat?
+ pkgPkgConfigDependencies = concatMap snd . CD.toList $ buildComponentDeps compPkgConfigDependencies
+ , -- NB: This is not the final setting of 'pkgStanzasEnabled'.
+ -- See [Sticky enabled testsuites]; we may enable some extra
+ -- stanzas opportunistically when it is cheap to do so.
+ --
+ -- However, we start off by enabling everything that was
+ -- requested, so that we can maintain an invariant that
+ -- pkgStanzasEnabled is a superset of elabStanzasRequested
+ pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested
+ , pkgWhyNotPerComponent
+ }
+ -- This tells us which components depend on the main library of this package.
+ -- Note: the sublib case should not occur, because sub-libraries are not
+ -- supported without per-component builds.
+ -- TODO: Add a check somewhere that this is the case.
+ pkgDependsOnSelfLib :: CD.ComponentDeps [()]
pkgDependsOnSelfLib =
CD.fromList
[ (CD.componentNameToComponent cn, [()])
- | Graph.N _ cn _ <- fromMaybe [] mb_closure
+ | Graph.N _ cn _ <- closure
]
where
- mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k]
- -- NB: the sublib case should not occur, because sub-libraries
- -- are not supported without per-component builds
- is_lib (CLibName _) = True
- is_lib _ = False
+ closure =
+ fromMaybe (error "elaborateSolverToPackage: internal error, no closure for main lib") $
+ Graph.revClosure compGraph [k | k@(CLibName LMainLibName) <- Graph.keys compGraph]
buildComponentDeps :: Monoid a => (ElaboratedComponent -> a) -> CD.ComponentDeps a
buildComponentDeps f =
@@ -2190,60 +2246,79 @@ elaborateInstallPlan
| ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} <- comps
]
- -- NB: This is not the final setting of 'pkgStanzasEnabled'.
- -- See [Sticky enabled testsuites]; we may enable some extra
- -- stanzas opportunistically when it is cheap to do so.
- --
- -- However, we start off by enabling everything that was
- -- requested, so that we can maintain an invariant that
- -- pkgStanzasEnabled is a superset of elabStanzasRequested
- pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested
-
elaborateSolverToCommon
:: SolverPackage UnresolvedPkgLoc
-> (ElaboratedConfiguredPackage, LogProgress ())
elaborateSolverToCommon
- pkg@( SolverPackage
- (SourcePackage pkgid gdesc srcloc descOverride)
- flags
- stanzas
- deps0
- _exe_deps0
- ) =
- (elaboratedPackage, wayWarnings pkgid)
+ solverPkg@SolverPackage
+ { solverPkgStage
+ , solverPkgSource =
+ SourcePackage
+ { srcpkgPackageId
+ , srcpkgDescription
+ , srcpkgSource
+ , srcpkgDescrOverride
+ }
+ , solverPkgFlags
+ , solverPkgStanzas
+ , solverPkgLibDeps
+ } =
+ (elaboratedPackage, buildOptionsAdjustmentWarnings)
where
+ compilers = fmap toolchainCompiler toolchains
+ platforms = fmap toolchainPlatform toolchains
+ programDbs = fmap toolchainProgramDb toolchains
+ packageDbs = fmap toolchainPackageDBs toolchains
+
elaboratedPackage = ElaboratedConfiguredPackage{..}
+ buildOptionsAdjustmentWarnings :: LogProgress ()
+ buildOptionsAdjustmentWarnings =
+ mapM_ (warnProgress . text) $
+ Cabal.buildOptionsAdjustmentWarnings
+ elabCompiler
+ elabBuildOptionsRaw
+ elabBuildOptions
+
-- These get filled in later
elabUnitId = error "elaborateSolverToCommon: elabUnitId"
elabComponentId = error "elaborateSolverToCommon: elabComponentId"
- elabInstantiatedWith = Map.empty
- elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith"
elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp"
elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs"
elabModuleShape = error "elaborateSolverToCommon: elabModuleShape"
elabIsCanonical = True
- elabPkgSourceId = pkgid
- elabPkgDescription = case PD.finalizePD
- flags
- elabEnabledSpec
- (const Satisfied)
- platform
- (compilerInfo compiler)
- []
- gdesc of
- Right (desc, _) -> desc
- Left _ -> error "Failed to finalizePD in elaborateSolverToCommon"
- elabFlagAssignment = flags
+ elabPkgSourceId = srcpkgPackageId
+
+ elabStage = solverPkgStage
+ elabCompiler = getStage compilers elabStage
+ elabPlatform = getStage platforms elabStage
+ elabProgramDb = getStage programDbs elabStage
+
+ elabPkgDescription =
+ case PD.finalizePD
+ solverPkgFlags
+ elabEnabledSpec
+ (const Satisfied)
+ elabPlatform
+ (compilerInfo elabCompiler)
+ []
+ srcpkgDescription of
+ Right (desc, _) -> desc
+ Left _ -> error "Failed to finalizePD in elaborateSolverToCommon"
+
+ elabGPkgDescription = srcpkgDescription
+
+ elabFlagAssignment = solverPkgFlags
+
elabFlagDefaults =
PD.mkFlagAssignment
[ (PD.flagName flag, PD.flagDefault flag)
- | flag <- PD.genPackageFlags gdesc
+ | flag <- PD.genPackageFlags srcpkgDescription
]
- elabEnabledSpec = enableStanzas stanzas
- elabStanzasAvailable = stanzas
+ elabEnabledSpec = enableStanzas solverPkgStanzas
+ elabStanzasAvailable = solverPkgStanzas
elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)
elabStanzasRequested = optStanzaTabulate $ \o -> case o of
@@ -2257,8 +2332,8 @@ elaborateInstallPlan
BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription]
where
tests, benchmarks :: Maybe Bool
- tests = perPkgOptionMaybe pkgid packageConfigTests
- benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks
+ tests = perPkgOptionMaybe srcpkgPackageId packageConfigTests
+ benchmarks = perPkgOptionMaybe srcpkgPackageId packageConfigBenchmarks
-- This is a placeholder which will get updated by 'pruneInstallPlanPass1'
-- and 'pruneInstallPlanPass2'. We can't populate it here
@@ -2276,7 +2351,7 @@ elaborateInstallPlan
elabHaddockTargets = []
elabBuildHaddocks =
- perPkgOptionFlag pkgid False packageConfigDocumentation
+ perPkgOptionFlag srcpkgPackageId False packageConfigDocumentation
-- `documentation: true` should imply `-haddock` for GHC
addHaddockIfDocumentationEnabled :: ConfiguredProgram -> ConfiguredProgram
@@ -2285,78 +2360,99 @@ elaborateInstallPlan
then cp{programOverrideArgs = "-haddock" : programOverrideArgs}
else cp
- elabPkgSourceLocation = srcloc
- elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes
- elabLocalToProject = isLocalToProject pkg
+ elabPkgSourceLocation = srcpkgSource
+
+ elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes
+
+ elabLocalToProject = isLocalToProject solverPkg
+
elabBuildStyle =
- if shouldBuildInplaceOnly pkg
+ if shouldBuildInplaceOnly solverPkg
then BuildInplaceOnly OnDisk
else BuildAndInstall
- elabPackageDbs = projectConfigPackageDBs sharedPackageConfig
- elabBuildPackageDBStack = buildAndRegisterDbs
- elabRegisterPackageDBStack = buildAndRegisterDbs
+
+ elabPackageDbs = getStage packageDbs elabStage
+ elabBuildPackageDBStack = buildAndRegisterDbs elabStage
+ elabRegisterPackageDBStack = buildAndRegisterDbs elabStage
elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription
+
elabSetupScriptCliVersion =
packageSetupScriptSpecVersion
elabSetupScriptStyle
elabPkgDescription
libDepGraph
- deps0
- elabSetupPackageDBStack = buildAndRegisterDbs
+ solverPkgLibDeps
+
+ elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage)
+
+ -- Same as corePackageDbs but with the addition of the in-place packagedb.
+ inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory "packagedb" prettyShow stage prettyShow (compilerId (getStage compilers stage)))]
- elabInplaceBuildPackageDBStack = inplacePackageDbs
- elabInplaceRegisterPackageDBStack = inplacePackageDbs
- elabInplaceSetupPackageDBStack = inplacePackageDbs
+ -- The project packagedbs (typically the global packagedb but others can be added) followed by the store.
+ corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout (getStage compilers stage)]
- buildAndRegisterDbs
- | shouldBuildInplaceOnly pkg = inplacePackageDbs
- | otherwise = corePackageDbs
+ elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage
+ elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage
+ elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage)
- elabPkgDescriptionOverride = descOverride
+ buildAndRegisterDbs stage
+ | shouldBuildInplaceOnly solverPkg = inplacePackageDbs stage
+ | otherwise = corePackageDbs stage
- elabBuildOptions =
+ elabPkgDescriptionOverride = srcpkgDescrOverride
+
+ -- Raw build options derived from per-package config.
+ -- This is the cabal-install equivalent of Cabal's 'buildOptionsFromConfigFlags',
+ -- except we have more information to go on than just ConfigFlags.
+ --
+ -- Options that depend on compiler and toolchain capabilities are
+ -- passed through 'Cabal.adjustBuildOptions', so that
+ -- 'elabBuildOptions' accurately reflects what will actually be built.
+ elabBuildOptionsRaw =
LBC.BuildOptions
- { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively
- , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary
- , withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib
+ { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively
+ , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary elabCompiler
+ , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib
+ , withBytecodeLib = perPkgOptionFlag srcpkgPackageId False packageConfigBytecodeLib
, withDynExe =
- perPkgOptionFlag pkgid False packageConfigDynExe
+ perPkgOptionFlag srcpkgPackageId False packageConfigDynExe
-- We can't produce a dynamic executable if the user
-- wants to enable executable profiling but the
-- compiler doesn't support prof+dyn.
&& (okProfDyn || not profExe)
- , withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe
- , withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still
- , withProfExe = profExe
- , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary
- , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared
- , withBytecodeLib = perPkgOptionFlag pkgid False packageConfigBytecodeLib
- , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage
- , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage
- , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization
- , splitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs
- , splitSections = perPkgOptionFlag pkgid False packageConfigSplitSections
- , stripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs
- , stripExes = perPkgOptionFlag pkgid False packageConfigStripExes
- , withDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo
- , relocatable = perPkgOptionFlag pkgid False packageConfigRelocatable
+ , withFullyStaticExe = perPkgOptionFlag srcpkgPackageId False packageConfigFullyStaticExe
+ , withGHCiLib = perPkgOptionFlag srcpkgPackageId False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still
+ , withProfExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf
+ , withProfLib = srcpkgPackageId `Set.member` pkgsUseProfilingLibrary elabCompiler
+ , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared elabCompiler
+ , exeCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage
+ , libCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage
+ , withOptimization = perPkgOptionFlag srcpkgPackageId NormalOptimisation packageConfigOptimization
+ , splitObjs = perPkgOptionFlag srcpkgPackageId False packageConfigSplitObjs
+ , splitSections = perPkgOptionFlag srcpkgPackageId False packageConfigSplitSections
+ , stripLibs = perPkgOptionFlag srcpkgPackageId False packageConfigStripLibs
+ , stripExes = perPkgOptionFlag srcpkgPackageId False packageConfigStripExes
+ , withDebugInfo = perPkgOptionFlag srcpkgPackageId NoDebugInfo packageConfigDebugInfo
+ , relocatable = perPkgOptionFlag srcpkgPackageId False packageConfigRelocatable
, withProfLibDetail = elabProfExeDetail
, withProfExeDetail = elabProfLibDetail
}
- okProfDyn = profilingDynamicSupportedOrUnknown compiler
- profExe = perPkgOptionFlag pkgid False packageConfigProf
+ okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler
+ profExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf
+
+ elabBuildOptions = Cabal.adjustBuildOptions elabCompiler elabProgramDb elabBuildOptionsRaw
( elabProfExeDetail
, elabProfLibDetail
) =
perPkgOptionLibExeFlag
- pkgid
+ srcpkgPackageId
ProfDetailDefault
packageConfigProfDetail
packageConfigProfLibDetail
- elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo
+ elabDumpBuildInfo = perPkgOptionFlag srcpkgPackageId NoDumpBuildInfo packageConfigDumpBuildInfo
-- Combine the configured compiler prog settings with the user-supplied
-- config. For the compiler progs any user-supplied config was taken
@@ -2366,59 +2462,63 @@ elaborateInstallPlan
elabProgramPaths =
Map.fromList
[ (programId prog, programPath prog)
- | prog <- configuredPrograms compilerprogdb
+ | prog <- configuredPrograms elabProgramDb
]
- <> perPkgOptionMapLast pkgid packageConfigProgramPaths
+ <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths
+
elabProgramArgs =
Map.unionWith
(++)
( Map.fromList
[ (programId prog, args)
- | prog <- configuredPrograms compilerprogdb
+ | prog <- configuredPrograms elabProgramDb
, let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog
, not (null args)
]
)
- (perPkgOptionMapMappend pkgid packageConfigProgramArgs)
- elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra
- elabConfiguredPrograms = configuredPrograms compilerprogdb
- elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs
- elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs
- elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic
- elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs
- elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs
- elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix
- elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix
-
- elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle
- elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml
- elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation
- elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs
- elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage
- elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables
- elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites
- elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks
- elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal
- elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss
- elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource
- elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump
- elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss
- elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents
- elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex
- elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl
- elabHaddockResourcesDir = perPkgOptionMaybe pkgid packageConfigHaddockResourcesDir
- elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir
- elabHaddockUseUnicode = perPkgOptionFlag pkgid False packageConfigHaddockUseUnicode
-
- elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog
- elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog
- elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails
- elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix
- elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper
- elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites
- elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions
-
- elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions
+ (perPkgOptionMapMappend srcpkgPackageId packageConfigProgramArgs)
+
+ elabProgramPathExtra = perPkgOptionNubList srcpkgPackageId packageConfigProgramPathExtra
+ elabConfiguredPrograms = configuredPrograms elabProgramDb
+ elabConfigureScriptArgs = perPkgOptionList srcpkgPackageId packageConfigConfigureArgs
+
+ elabExtraLibDirs = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirs
+ elabExtraLibDirsStatic = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirsStatic
+ elabExtraFrameworkDirs = perPkgOptionList srcpkgPackageId packageConfigExtraFrameworkDirs
+ elabExtraIncludeDirs = perPkgOptionList srcpkgPackageId packageConfigExtraIncludeDirs
+
+ elabProgPrefix = perPkgOptionMaybe srcpkgPackageId packageConfigProgPrefix
+ elabProgSuffix = perPkgOptionMaybe srcpkgPackageId packageConfigProgSuffix
+
+ elabHaddockHoogle = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHoogle
+ elabHaddockHtml = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHtml
+ elabHaddockHtmlLocation = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHtmlLocation
+ elabHaddockForeignLibs = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockForeignLibs
+ elabHaddockForHackage = perPkgOptionFlag srcpkgPackageId Cabal.ForDevelopment packageConfigHaddockForHackage
+ elabHaddockExecutables = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockExecutables
+ elabHaddockTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockTestSuites
+ elabHaddockBenchmarks = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockBenchmarks
+ elabHaddockInternal = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockInternal
+ elabHaddockCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockCss
+ elabHaddockLinkedSource = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockLinkedSource
+ elabHaddockQuickJump = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockQuickJump
+ elabHaddockHscolourCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHscolourCss
+ elabHaddockContents = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockContents
+ elabHaddockIndex = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockIndex
+ elabHaddockBaseUrl = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockBaseUrl
+ elabHaddockResourcesDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockResourcesDir
+ elabHaddockOutputDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockOutputDir
+ elabHaddockUseUnicode = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockUseUnicode
+
+ elabTestMachineLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestMachineLog
+ elabTestHumanLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestHumanLog
+ elabTestShowDetails = perPkgOptionMaybe srcpkgPackageId packageConfigTestShowDetails
+ elabTestKeepTix = perPkgOptionFlag srcpkgPackageId False packageConfigTestKeepTix
+ elabTestWrapper = perPkgOptionMaybe srcpkgPackageId packageConfigTestWrapper
+ elabTestFailWhenNoTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigTestFailWhenNoTestSuites
+ elabTestTestOptions = perPkgOptionList srcpkgPackageId packageConfigTestTestOptions
+
+ elabBenchmarkOptions = perPkgOptionList srcpkgPackageId packageConfigBenchmarkOptions
perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a
perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a
@@ -2435,7 +2535,6 @@ elaborateInstallPlan
where
exe = fromFlagOrDefault def bothflag
lib = fromFlagOrDefault def (bothflag <> libflag)
-
bothflag = lookupPerPkgOption pkgid fboth
libflag = lookupPerPkgOption pkgid flib
@@ -2458,12 +2557,6 @@ elaborateInstallPlan
mempty
perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)
- inplacePackageDbs =
- corePackageDbs
- ++ [distPackageDB (compilerId compiler)]
-
- corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig)
-
-- For this local build policy, every package that lives in a local source
-- dir (as opposed to a tarball), or depends on such a package, will be
-- built inplace into a shared dist dir. Tarball packages that depend on
@@ -2471,16 +2564,18 @@ elaborateInstallPlan
shouldBuildInplaceOnly :: SolverPackage loc -> Bool
shouldBuildInplaceOnly pkg =
Set.member
- (packageId pkg)
+ (solverId (ResolverPackage.Configured pkg))
pkgsToBuildInplaceOnly
- pkgsToBuildInplaceOnly :: Set PackageId
+ -- The reverse dependencies of solver packages which match a package id in pkgLocalToProject.
+ pkgsToBuildInplaceOnly :: Set SolverId
pkgsToBuildInplaceOnly =
- Set.fromList $
- map packageId $
- SolverInstallPlan.reverseDependencyClosure
- solverPlan
- (map PlannedId (Set.toList pkgsLocalToProject))
+ Set.fromList
+ [ solverId pkg
+ | spkg <- SolverInstallPlan.toList solverPlan
+ , packageId spkg `elem` pkgsLocalToProject
+ , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan [solverId spkg]
+ ]
isLocalToProject :: Package pkg => pkg -> Bool
isLocalToProject pkg =
@@ -2494,11 +2589,11 @@ elaborateInstallPlan
-- TODO: localPackages is a misnomer, it's all project packages
-- here is where we decide which ones will be local!
- pkgsUseSharedLibrary :: Set PackageId
- pkgsUseSharedLibrary =
- packagesWithLibDepsDownwardClosedProperty needsSharedLib
+ pkgsUseSharedLibrary :: Compiler -> Set PackageId
+ pkgsUseSharedLibrary compiler =
+ packagesWithLibDepsDownwardClosedProperty (needsSharedLib compiler)
- needsSharedLib pkgid =
+ needsSharedLib compiler pkgid =
fromMaybe
compilerShouldUseSharedLibByDefault
-- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that.
@@ -2523,63 +2618,48 @@ elaborateInstallPlan
pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe
pkgProf = perPkgOptionMaybe pkgid packageConfigProf
- -- TODO: [code cleanup] move this into the Cabal lib. It's currently open
- -- coded in Distribution.Simple.Configure, but should be made a proper
- -- function of the Compiler or CompilerInfo.
- compilerShouldUseSharedLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs
- GHCJS -> GHCJS.isDynamic compiler
- _ -> False
-
- compilerShouldUseProfilingLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs
- _ -> False
-
- compilerShouldUseProfilingSharedLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs
- _ -> False
-
- -- Returns False if we definitely can't build shared libs
- canBuildWayLibs predicate = case predicate compiler of
- Just can_build -> can_build
- -- If we don't know for certain, just assume we can
- -- which matches behaviour in previous cabal releases
- Nothing -> True
-
- canBuildSharedLibs = canBuildWayLibs dynamicSupported
- canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported
- canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported
-
- wayWarnings pkg = do
- when
- (needsProfilingLib pkg && not canBuildProfilingLibs)
- (warnProgress (text "Compiler does not support building p libraries, profiling is disabled"))
- when
- (needsSharedLib pkg && not canBuildSharedLibs)
- (warnProgress (text "Compiler does not support building dyn libraries, dynamic libraries are disabled"))
- when
- (needsProfilingLibShared pkg && not canBuildProfilingSharedLibs)
- (warnProgress (text "Compiler does not support building p_dyn libraries, profiling dynamic libraries are disabled."))
-
- pkgsUseProfilingLibrary :: Set PackageId
- pkgsUseProfilingLibrary =
- packagesWithLibDepsDownwardClosedProperty needsProfilingLib
-
- needsProfilingLib pkg =
+ compilerShouldUseSharedLibByDefault =
+ case compilerFlavor compiler of
+ GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs
+ GHCJS -> GHCJS.isDynamic compiler
+ _ -> False
+
+ canBuildWayLibs predicate = case predicate compiler of
+ Just can_build -> can_build
+ -- If we don't know for certain, just assume we can
+ -- which matches behaviour in previous cabal releases
+ Nothing -> True
+
+ canBuildSharedLibs = canBuildWayLibs dynamicSupported
+ canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported
+
+ pkgsUseProfilingLibrary :: Compiler -> Set PackageId
+ pkgsUseProfilingLibrary compiler =
+ packagesWithLibDepsDownwardClosedProperty (needsProfilingLib compiler)
+
+ needsProfilingLib compiler pkg =
fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag)
where
pkgid = packageId pkg
profBothFlag = lookupPerPkgOption pkgid packageConfigProf
profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib
- pkgsUseProfilingLibraryShared :: Set PackageId
- pkgsUseProfilingLibraryShared =
- packagesWithLibDepsDownwardClosedProperty needsProfilingLibShared
+ compilerShouldUseProfilingLibByDefault =
+ case compilerFlavor compiler of
+ GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs
+ _ -> False
+
+ canBuildWayLibs predicate = case predicate compiler of
+ Just can_build -> can_build
+ Nothing -> True
+
+ canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported
- needsProfilingLibShared pkg =
+ pkgsUseProfilingLibraryShared :: Compiler -> Set PackageId
+ pkgsUseProfilingLibraryShared compiler =
+ packagesWithLibDepsDownwardClosedProperty (needsProfilingLibShared compiler)
+
+ needsProfilingLibShared compiler pkg =
fromMaybe
compilerShouldUseProfilingSharedLibByDefault
-- case 1: If --enable-profiling-shared is passed explicitly, honour that
@@ -2603,6 +2683,17 @@ elaborateInstallPlan
pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe
pkgProf = perPkgOptionMaybe pkgid packageConfigProf
+ compilerShouldUseProfilingSharedLibByDefault =
+ case compilerFlavor compiler of
+ GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs
+ _ -> False
+
+ canBuildWayLibs predicate = case predicate compiler of
+ Just can_build -> can_build
+ Nothing -> True
+
+ canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported
+
-- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe
libDepGraph =
@@ -2611,6 +2702,7 @@ elaborateInstallPlan
NonSetupLibDepSolverPlanPackage
(SolverInstallPlan.toList solverPlan)
+ packagesWithLibDepsDownwardClosedProperty :: (PackageIdentifier -> Bool) -> Set PackageIdentifier
packagesWithLibDepsDownwardClosedProperty property =
Set.fromList
. maybe [] (map packageId)
@@ -2634,14 +2726,17 @@ elaborateInstallPlan
-- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping
shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId
-shouldBeLocal NamedPackage{} = Nothing
-shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of
- LocalUnpackedPackage _ -> Just (packageId pkg)
- _ -> Nothing
+shouldBeLocal (NamedPackage _ _) =
+ Nothing
+shouldBeLocal (SpecificSourcePackage pkg) =
+ case srcpkgSource pkg of
+ LocalUnpackedPackage _ -> Just (packageId pkg)
+ _ -> Nothing
-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'.
+-- TODO: check the role of stage here.
matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool
-matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p)
+matchPlanPkg p = InstallPlan.foldPlanPackage (\(WithStage _stage ipkg) -> p (ipiComponentName ipkg)) (matchElabPkg p)
-- | Get the appropriate 'ComponentName' which identifies an installed
-- component.
@@ -2667,15 +2762,14 @@ matchElabPkg p elab =
(p . componentName)
(Cabal.pkgBuildableComponents (elabPkgDescription elab))
--- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName'
--- and 'ComponentName' to the 'ComponentId' that should be used
--- in this case.
+-- | Extract from an 'ElaboratedPlanPackage' a mapping from package and component name
+-- to a component id.
mkCCMapping
:: ElaboratedPlanPackage
-> (PackageName, Map ComponentName (AnnotatedId ComponentId))
mkCCMapping =
InstallPlan.foldPlanPackage
- ( \ipkg ->
+ ( \(WithStage _ ipkg) ->
( packageName ipkg
, Map.singleton
(ipiComponentName ipkg)
@@ -2699,12 +2793,14 @@ mkCCMapping =
, case elabPkgOrComp elab of
ElabComponent comp ->
case compComponentName comp of
+ -- This should be an error because we cannot explicitly depend on a setup
Nothing -> Map.empty
Just n -> Map.singleton n (mk_aid n)
ElabPackage _ ->
Map.fromList $
map
(\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn))
+ -- Shouldn't this be available in ElaboratedPackage?
(Cabal.pkgBuildableComponents (elabPkgDescription elab))
)
@@ -2718,9 +2814,8 @@ mkShapeMapping dpkg =
where
(dcid, shape) =
InstallPlan.foldPlanPackage
- -- Uses Monad (->)
- (liftM2 (,) IPI.installedComponentId shapeInstalledPackage)
- (liftM2 (,) elabComponentId elabModuleShape)
+ (\(WithStage _stage ipkg) -> (IPI.installedComponentId ipkg, shapeInstalledPackage ipkg))
+ (\elab -> (elabComponentId elab, elabModuleShape elab))
dpkg
indef_uid =
IndefFullUnitId
@@ -2762,13 +2857,13 @@ binDirectories layout config package = case elabBuildStyle package of
distBuildDirectory layout (elabDistDirParams config package)
"build"
-type InstS = Map UnitId ElaboratedPlanPackage
+type InstS = Map (WithStage UnitId) ElaboratedPlanPackage
type InstM a = State InstS a
getComponentId
:: ElaboratedPlanPackage
-> ComponentId
-getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg
+getComponentId (InstallPlan.PreExisting (WithStage _stage dipkg)) = IPI.installedComponentId dipkg
getComponentId (InstallPlan.Configured elab) = elabComponentId elab
getComponentId (InstallPlan.Installed elab) = elabComponentId elab
@@ -2778,6 +2873,17 @@ extractElabBuildStyle
extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab
extractElabBuildStyle _ = BuildAndInstall
+-- When using Backpack, packages can have "holes" that need to be filled with concrete implementations.
+
+-- This function takes an initial install plan and creates additional plan entries for all the instantiated versions of packages
+
+-- The function deals with:
+
+-- Indefinite packages - Packages with holes/signatures that need to be filled
+-- Instantiated packages - Concrete packages created by filling holes with specific implementations
+-- Component IDs - Unique identifiers for components (libraries, executables etc.)
+-- Unit IDs - Identifiers that track how holes are filled in instantiated packages
+
-- instantiateInstallPlan is responsible for filling out an InstallPlan
-- with all of the extra Configured packages that would be generated by
-- recursively instantiating the dependencies of packages.
@@ -2822,75 +2928,87 @@ extractElabBuildStyle _ = BuildAndInstall
-- * We use the state monad to cache already instantiated modules, so
-- we don't instantiate the same thing multiple times.
--
-instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan
-instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
- InstallPlan.new
- (IndependentGoals False)
- (Graph.fromDistinctList (Map.elems ready_map))
+instantiateInstallPlan
+ :: HasCallStack
+ => StoreDirLayout
+ -> Staged InstallDirs.InstallDirTemplates
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> LogProgress ElaboratedInstallPlan
+instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = do
+ InstallPlan.new (Map.elems ready_map)
where
pkgs = InstallPlan.toList plan
- cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs]
+ cmap = Map.fromList [(WithStage (stageOf pkg) (getComponentId pkg), pkg) | pkg <- pkgs]
instantiateUnitId
- :: ComponentId
+ :: Stage
+ -> ComponentId
+ -- \^ The id of the component being instantiated
-> Map ModuleName (Module, BuildStyle)
+ -- \^ A mapping from module names (the "holes" or signatures in Backpack)
+ -- to the concrete modules (and their build styles) that should fill those
+ -- holes.
-> InstM (DefUnitId, BuildStyle)
- instantiateUnitId cid insts = state $ \s ->
- case Map.lookup uid s of
- Nothing ->
- -- Knot tied
- -- TODO: I don't think the knot tying actually does
- -- anything useful
- let (r, s') =
- runState
- (instantiateComponent uid cid insts)
- (Map.insert uid r s)
- in ((def_uid, extractElabBuildStyle r), Map.insert uid r s')
- Just r -> ((def_uid, extractElabBuildStyle r), s)
+ instantiateUnitId stage cid insts =
+ gets (Map.lookup (WithStage stage uid)) >>= \case
+ Nothing -> do
+ r <- instantiateComponent uid (WithStage stage cid) insts
+ modify (Map.insert (WithStage stage uid) r)
+ return (unsafeMkDefUnitId uid, extractElabBuildStyle r)
+ Just r ->
+ return (unsafeMkDefUnitId uid, extractElabBuildStyle r)
where
- def_uid = mkDefUnitId cid (fmap fst insts)
- uid = unDefUnitId def_uid
+ uid = mkDefUnitId cid (fmap fst insts)
-- No need to InplaceT; the inplace-ness is properly computed for
-- the ElaboratedPlanPackage, so that will implicitly pass it on
instantiateComponent
:: UnitId
- -> ComponentId
+ -- \^ The unit id to assign to the instantiated component
+ -> WithStage ComponentId
+ -- \^ The id of the component being instantiated
-> Map ModuleName (Module, BuildStyle)
+ -- \^ A mapping from module names (the "holes" or signatures in Backpack)
+ -- to the concrete modules (and their build styles) that should fill those
+ -- holes.
-> InstM ElaboratedPlanPackage
- instantiateComponent uid cid insts
- | Just planpkg <- Map.lookup cid cmap =
+ instantiateComponent uid cidws@(WithStage stage cid) insts =
+ case Map.lookup cidws cmap of
+ Nothing -> error ("instantiateComponent: " ++ prettyShow cid)
+ Just planpkg ->
case planpkg of
- InstallPlan.Configured
- ( elab0@ElaboratedConfiguredPackage
- { elabPkgOrComp = ElabComponent comp
- }
- ) -> do
- deps <-
- traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)
- let build_style = fold (fmap snd insts)
- let getDep (Module dep_uid _) = [dep_uid]
- elab1 =
- fixupBuildStyle build_style $
- elab0
- { elabUnitId = uid
- , elabComponentId = cid
- , elabInstantiatedWith = fmap fst insts
- , elabIsCanonical = Map.null (fmap fst insts)
- , elabPkgOrComp =
- ElabComponent
- comp
- { compOrderLibDependencies =
- [newSimpleUnitId cid | not (Map.null insts)]
- ++ ordNub
- ( map
- unDefUnitId
- (deps ++ concatMap (getDep . fst) (Map.elems insts))
- )
- }
- }
- elab =
+ InstallPlan.Installed{} -> return planpkg
+ InstallPlan.PreExisting{} -> return planpkg
+ InstallPlan.Configured elab0 ->
+ case elabPkgOrComp elab0 of
+ ElabPackage{} -> return planpkg
+ ElabComponent comp -> do
+ deps <- traverse (fmap fst . instantiateUnit stage insts) (compLinkedLibDependencies comp)
+ let build_style = fold (fmap snd insts)
+ let getDep (Module dep_uid _) = [dep_uid]
+ elab1 =
+ fixupBuildStyle build_style $
+ elab0
+ { elabUnitId = uid
+ , elabComponentId = cid
+ , elabIsCanonical = Map.null (fmap fst insts)
+ , elabPkgOrComp =
+ ElabComponent
+ comp
+ { compOrderLibDependencies =
+ (if Map.null insts then [] else [newSimpleUnitId cid])
+ ++ ordNub
+ ( map
+ unDefUnitId
+ (deps ++ concatMap (getDep . fst) (Map.elems insts))
+ )
+ , compInstantiatedWith = fmap fst insts
+ }
+ }
+ return $
+ InstallPlan.Configured
elab1
{ elabInstallDirs =
computeInstallDirs
@@ -2899,112 +3017,135 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
elaboratedShared
elab1
}
- return $ InstallPlan.Configured elab
- _ -> return planpkg
- | otherwise = error ("instantiateComponent: " ++ prettyShow cid)
- substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle)
- substUnitId _ (DefiniteUnitId uid) =
+ -- \| Instantiates an OpenUnitId into a concrete UnitId, producing a concrete UnitId and its associated BuildStyle.
+ --
+ -- This function recursively applies a module substitution to an OpenUnitId, producing a fully instantiated
+ -- (definite) unit and its build style. This is a key step in Backpack-style instantiation, where "holes" in
+ -- a package are filled with concrete modules.
+ --
+ -- Behavior
+ --
+ -- If given a DefiniteUnitId, it returns the id and a default build style (BuildAndInstall).
+ --
+ -- If given an IndefFullUnitId, it:
+ -- Recursively applies the substitution to each module in the instantiation map using substSubst.
+ -- Calls instantiateUnitId to create or retrieve the fully instantiated unit id and build style for this instantiation.
+ --
+ instantiateUnit
+ :: Stage
+ -> Map ModuleName (Module, BuildStyle)
+ -- \^ A mapping from module names to their corresponding modules and build styles.
+ -> OpenUnitId
+ -- \^ The unit to instantiate. This can be:
+ -- DefiniteUnitId uid: already fully instantiated (no holes).
+ -- IndefFullUnitId cid insts: an indefinite unit (with holes), described by a component id and a mapping of holes to modules.
+ -> InstM (DefUnitId, BuildStyle)
+ instantiateUnit _stage _subst (DefiniteUnitId def_uid) =
-- This COULD actually, secretly, be an inplace package, but in
-- that case it doesn't matter as it's already been recorded
-- in the package that depends on this
- return (uid, BuildAndInstall)
- substUnitId subst (IndefFullUnitId cid insts) = do
- insts' <- substSubst subst insts
- instantiateUnitId cid insts'
-
- -- NB: NOT composition
- substSubst
- :: Map ModuleName (Module, BuildStyle)
- -> Map ModuleName OpenModule
- -> InstM (Map ModuleName (Module, BuildStyle))
- substSubst subst insts = traverse (substModule subst) insts
-
- substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle)
- substModule subst (OpenModuleVar mod_name)
+ return (def_uid, BuildAndInstall)
+ instantiateUnit stage subst (IndefFullUnitId cid insts) = do
+ insts' <- traverse (instantiateModule stage subst) insts
+ instantiateUnitId stage cid insts'
+
+ -- \| Instantiates an OpenModule into a concrete Module producing a concrete Module
+ -- and its associated BuildStyle.
+ instantiateModule
+ :: Stage
+ -> Map ModuleName (Module, BuildStyle)
+ -- \^ A mapping from module names to their corresponding modules and build styles.
+ -> OpenModule
+ -- \^ The module to substitute, which can be:
+ -- OpenModuleVar mod_name: a hole (variable) named mod_name
+ -- OpenModule uid mod_name: a module from a specific unit (uid).
+ -> InstM (Module, BuildStyle)
+ instantiateModule _stage 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', build_style) <- substUnitId subst uid
+ instantiateModule stage subst (OpenModule uid mod_name) = do
+ (uid', build_style) <- instantiateUnit stage subst uid
return (Module uid' mod_name, build_style)
- indefiniteUnitId :: ComponentId -> InstM UnitId
- indefiniteUnitId cid = do
- let uid = newSimpleUnitId cid
- r <- indefiniteComponent uid cid
- state $ \s -> (uid, Map.insert uid r s)
-
- indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage
- indefiniteComponent _uid cid
- -- Only need Configured; this phase happens before improvement, so
- -- there shouldn't be any Installed packages here.
- | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap
- , ElabComponent elab_comp <- elabPkgOrComp epkg =
- do
- -- We need to do a little more processing of the includes: some
- -- of them are fully definite even without substitution. We
- -- want to build those too; see #5634.
- --
- -- This code mimics similar code in Distribution.Backpack.ReadyComponent;
- -- however, unlike the conversion from LinkedComponent to
- -- ReadyComponent, this transformation is done *without*
- -- changing the type in question; and what we are simply
- -- doing is enforcing tighter invariants on the data
- -- structure in question. The new invariant is that there
- -- is no IndefFullUnitId in compLinkedLibDependencies that actually
- -- has no holes. We couldn't specify this invariant when
- -- we initially created the ElaboratedPlanPackage because
- -- we have no way of actually reifying the UnitId into a
- -- DefiniteUnitId (that's what substUnitId does!)
- new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->
- if Set.null (openUnitIdFreeHoles uid)
- then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid)
- else return uid
- -- NB: no fixupBuildStyle needed here, as if the indefinite
- -- component depends on any inplace packages, it itself must
- -- be indefinite! There is no substitution here, we can't
- -- post facto add inplace deps
- return . InstallPlan.Configured $
- epkg
- { elabPkgOrComp =
- ElabComponent
- elab_comp
- { compLinkedLibDependencies = new_deps
- , -- I think this is right: any new definite unit ids we
- -- minted in the phase above need to be built before us.
- -- Add 'em in. This doesn't remove any old dependencies
- -- on the indefinite package; they're harmless.
- compOrderLibDependencies =
- ordNub $
- compOrderLibDependencies elab_comp
- ++ [unDefUnitId d | DefiniteUnitId d <- new_deps]
- }
- }
- | Just planpkg <- Map.lookup cid cmap =
- return planpkg
- | otherwise = error ("indefiniteComponent: " ++ prettyShow cid)
+ indefiniteComponent
+ :: ElaboratedConfiguredPackage
+ -> InstM ElaboratedConfiguredPackage
+ indefiniteComponent epkg =
+ case elabPkgOrComp epkg of
+ ElabPackage{} -> return epkg
+ ElabComponent elab_comp -> do
+ -- We need to do a little more processing of the includes: some
+ -- of them are fully definite even without substitution. We
+ -- want to build those too; see #5634.
+ --
+ -- This code mimics similar code in Distribution.Backpack.ReadyComponent;
+ -- however, unlike the conversion from LinkedComponent to
+ -- ReadyComponent, this transformation is done *without*
+ -- changing the type in question; and what we are simply
+ -- doing is enforcing tighter invariants on the data
+ -- structure in question. The new invariant is that there
+ -- is no IndefFullUnitId in compLinkedLibDependencies that actually
+ -- has no holes. We couldn't specify this invariant when
+ -- we initially created the ElaboratedPlanPackage because
+ -- we have no way of actually reifying the UnitId into a
+ -- DefiniteUnitId (that's what substUnitId does!)
+ new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->
+ if Set.null (openUnitIdFreeHoles uid)
+ then fmap (DefiniteUnitId . fst) (instantiateUnit (elabStage epkg) Map.empty uid)
+ else return uid
+ -- NB: no fixupBuildStyle needed here, as if the indefinite
+ -- component depends on any inplace packages, it itself must
+ -- be indefinite! There is no substitution here, we can't
+ -- post facto add inplace deps
+ return
+ epkg
+ { elabPkgOrComp =
+ ElabComponent
+ elab_comp
+ { compLinkedLibDependencies = new_deps
+ , -- I think this is right: any new definite unit ids we
+ -- minted in the phase above need to be built before us.
+ -- Add 'em in. This doesn't remove any old dependencies
+ -- on the indefinite package; they're harmless.
+ compOrderLibDependencies =
+ ordNub $
+ compOrderLibDependencies elab_comp
+ ++ [unDefUnitId d | DefiniteUnitId d <- new_deps]
+ }
+ }
fixupBuildStyle BuildAndInstall elab = elab
- fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab
- fixupBuildStyle t@(BuildInplaceOnly{}) elab =
+ fixupBuildStyle _buildStyle (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab
+ fixupBuildStyle buildStyle@(BuildInplaceOnly{}) elab =
elab
- { elabBuildStyle = t
+ { elabBuildStyle = buildStyle
, elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab
, elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab
, elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab
}
ready_map = execState work Map.empty
-
work = for_ pkgs $ \pkg ->
case pkg of
- InstallPlan.Configured elab
- | not (Map.null (elabLinkedInstantiatedWith elab)) ->
- indefiniteUnitId (elabComponentId elab)
- >> return ()
+ InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp})
+ | not (Map.null (compLinkedInstantiatedWith comp)) -> do
+ r <- indefiniteComponent elab
+ modify (Map.insert (WithStage (elabStage elab) (elabUnitId elab)) (InstallPlan.Configured r))
_ ->
- instantiateUnitId (getComponentId pkg) Map.empty
- >> return ()
+ void $ instantiateUnitId (stageOf pkg) (getComponentId pkg) Map.empty
+
+-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
+-- with no holes.
+--
+-- This function is defined in Cabal-syntax but only cabal-install
+-- cares about it so I am putting it here.
+--
+-- I am also not using the DefUnitId newtype since I believe it
+-- provides little value in the code above.
+mkDefUnitId :: ComponentId -> Map ModuleName Module -> UnitId
+mkDefUnitId cid insts =
+ mkUnitId (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
---------------------------
-- Build targets
@@ -3096,15 +3237,17 @@ availableTargets
:: ElaboratedInstallPlan
-> Map
(PackageId, ComponentName)
- [AvailableTarget (UnitId, ComponentName)]
+ [AvailableTarget (WithStage UnitId, ComponentName)]
availableTargets installPlan =
let rs =
[ (pkgid, cname, fake, target)
| pkg <- InstallPlan.toList installPlan
- , (pkgid, cname, fake, target) <- case pkg of
+ , (stage, pkgid, cname, fake, target) <- case pkg of
InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg
InstallPlan.Installed elab -> availableSourceTargets elab
InstallPlan.Configured elab -> availableSourceTargets elab
+ , -- Only host stage can be explicitly requested by the user
+ stage == Host
]
in Map.union
( Map.fromListWith
@@ -3127,27 +3270,29 @@ availableTargets installPlan =
-- more details on this fake stuff is about.
availableInstalledTargets
- :: IPI.InstalledPackageInfo
- -> [ ( PackageId
+ :: WithStage IPI.InstalledPackageInfo
+ -> [ ( Stage
+ , PackageId
, ComponentName
, Bool
- , AvailableTarget (UnitId, ComponentName)
+ , AvailableTarget (WithStage UnitId, ComponentName)
)
]
-availableInstalledTargets ipkg =
+availableInstalledTargets (WithStage stage ipkg) =
let unitid = installedUnitId ipkg
cname = CLibName LMainLibName
- status = TargetBuildable (unitid, cname) TargetRequestedByDefault
+ status = TargetBuildable (WithStage stage unitid, cname) TargetRequestedByDefault
target = AvailableTarget (packageId ipkg) cname status False
fake = False
- in [(packageId ipkg, cname, fake, target)]
+ in [(stage, IPI.sourcePackageId ipkg, cname, fake, target)]
availableSourceTargets
:: ElaboratedConfiguredPackage
- -> [ ( PackageId
+ -> [ ( Stage
+ , PackageId
, ComponentName
, Bool
- , AvailableTarget (UnitId, ComponentName)
+ , AvailableTarget (WithStage UnitId, ComponentName)
)
]
availableSourceTargets elab =
@@ -3181,7 +3326,7 @@ availableSourceTargets elab =
-- map (thus eliminating the duplicates) and then we overlay that map with
-- the normal buildable targets. (This is done above in 'availableTargets'.)
--
- [ (packageId elab, cname, fake, target)
+ [ (elabStage elab, elabPkgSourceId elab, cname, fake, target)
| component <- pkgComponents (elabPkgDescription elab)
, let cname = componentName component
status = componentAvailableTargetStatus component
@@ -3215,7 +3360,7 @@ availableSourceTargets elab =
/= Just cname
componentAvailableTargetStatus
- :: Component -> AvailableTargetStatus (UnitId, ComponentName)
+ :: Component -> AvailableTargetStatus (WithStage UnitId, ComponentName)
componentAvailableTargetStatus component =
case componentOptionalStanza $ CD.componentNameToComponent cname of
-- it is not an optional stanza, so a library, exe or foreign lib
@@ -3223,7 +3368,7 @@ availableSourceTargets elab =
| not buildable -> TargetNotBuildable
| otherwise ->
TargetBuildable
- (elabUnitId elab, cname)
+ (WithStage (elabStage elab) (elabUnitId elab), cname)
TargetRequestedByDefault
-- it is not an optional stanza, so a testsuite or benchmark
Just stanza ->
@@ -3236,11 +3381,11 @@ availableSourceTargets elab =
_ | not buildable -> TargetNotBuildable
(Just True, True) ->
TargetBuildable
- (elabUnitId elab, cname)
+ (WithStage (elabStage elab) (elabUnitId elab), cname)
TargetRequestedByDefault
(Nothing, True) ->
TargetBuildable
- (elabUnitId elab, cname)
+ (WithStage (elabStage elab) (elabUnitId elab), cname)
TargetNotRequestedByDefault
(Just True, False) ->
error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname
@@ -3271,8 +3416,7 @@ nubComponentTargets =
concatMap (wholeComponentOverrides . map snd)
. groupBy ((==) `on` fst)
. sortBy (compare `on` fst)
- . map (\t@((ComponentTarget cname _, _)) -> (cname, t))
- . map compatSubComponentTargets
+ . map ((\t@((ComponentTarget cname _, _)) -> (cname, t)) . compatSubComponentTargets)
where
-- If we're building the whole component then that the only target all we
-- need, otherwise we can have several targets within the component.
@@ -3350,13 +3494,13 @@ data TargetAction
-- will prune differently depending on what is already installed (to
-- implement "sticky" test suite enabling behavior).
pruneInstallPlanToTargets
- :: TargetAction
- -> Map UnitId [ComponentTarget]
- -> ElaboratedInstallPlan
+ :: HasCallStack
+ => TargetAction
+ -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget]
-> ElaboratedInstallPlan
+ -> LogProgress ElaboratedInstallPlan
pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan =
- InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
- . Graph.fromDistinctList
+ InstallPlan.new
-- We have to do the pruning in two passes
. pruneInstallPlanPass2
. pruneInstallPlanPass1
@@ -3372,16 +3516,16 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan =
--
-- For 'ElaboratedComponent', this the cached unit IDs always
-- coincide with the real thing.
-data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId]
+data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [WithStage UnitId]
instance Package PrunedPackage where
packageId (PrunedPackage elab _) = packageId elab
instance HasUnitId PrunedPackage where
- installedUnitId = Graph.nodeKey
+ installedUnitId (PrunedPackage elab _) = installedUnitId elab
instance Graph.IsNode PrunedPackage where
- type Key PrunedPackage = UnitId
+ type Key PrunedPackage = WithStage UnitId
nodeKey (PrunedPackage elab _) = Graph.nodeKey elab
nodeNeighbors (PrunedPackage _ deps) = deps
@@ -3392,7 +3536,7 @@ fromPrunedPackage (PrunedPackage elab _) = elab
-- This is required before we can prune anything.
setRootTargets
:: TargetAction
- -> Map UnitId [ComponentTarget]
+ -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget]
-> [ElaboratedPlanPackage]
-> [ElaboratedPlanPackage]
setRootTargets targetAction perPkgTargetsMap =
@@ -3405,7 +3549,7 @@ setRootTargets targetAction perPkgTargetsMap =
-- dependencies. Those comes in the second pass once we know the rev deps.
--
setElabBuildTargets elab =
- case ( Map.lookup (installedUnitId elab) perPkgTargetsMap
+ case ( Map.lookup (Graph.nodeKey elab) perPkgTargetsMap
, targetAction
) of
(Nothing, _) -> elab
@@ -3446,7 +3590,8 @@ setRootTargets targetAction perPkgTargetsMap =
-- are used only by unneeded optional stanzas. These pruned deps are only
-- used for the dependency closure and are not persisted in this pass.
pruneInstallPlanPass1
- :: [ElaboratedPlanPackage]
+ :: HasCallStack
+ => [ElaboratedPlanPackage]
-> [ElaboratedPlanPackage]
pruneInstallPlanPass1 pkgs
-- if there are repl targets, we need to do a bit more work
@@ -3455,7 +3600,7 @@ pruneInstallPlanPass1 pkgs
-- otherwise we'll do less
| otherwise = pruned_packages
where
- pkgs' :: [InstallPlan.GenericPlanPackage IPI.InstalledPackageInfo PrunedPackage]
+ pkgs' :: [InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage]
pkgs' = map (mapConfiguredPackage prune) pkgs
prune :: ElaboratedConfiguredPackage -> PrunedPackage
@@ -3465,8 +3610,8 @@ pruneInstallPlanPass1 pkgs
graph = Graph.fromDistinctList pkgs'
- roots :: [UnitId]
- roots = mapMaybe find_root pkgs'
+ roots :: [Graph.Key ElaboratedPlanPackage]
+ roots = map Graph.nodeKey (filter is_root pkgs')
-- Make a closed graph by calculating the closure from the roots
pruned_packages :: [ElaboratedPlanPackage]
@@ -3505,25 +3650,21 @@ pruneInstallPlanPass1 pkgs
| anyMultiReplTarget = map (mapConfiguredPackage add_repl_target) (Graph.toList closed_graph)
| otherwise = Graph.toList closed_graph
- is_root :: PrunedPackage -> Maybe UnitId
- is_root (PrunedPackage elab _) =
- if not $
- and
- [ null (elabConfigureTargets elab)
- , null (elabBuildTargets elab)
- , null (elabTestTargets elab)
- , null (elabBenchTargets elab)
- , null (elabReplTarget elab)
- , null (elabHaddockTargets elab)
- ]
- then Just (installedUnitId elab)
- else Nothing
-
- find_root (InstallPlan.Configured pkg) = is_root pkg
- -- When using the extra-packages stanza we need to
- -- look at installed packages as well.
- find_root (InstallPlan.Installed pkg) = is_root pkg
- find_root _ = Nothing
+ is_root :: InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage -> Bool
+ is_root =
+ foldPlanPackage
+ (const False)
+ ( \(PrunedPackage elab _) ->
+ not $
+ and
+ [ null (elabConfigureTargets elab)
+ , null (elabBuildTargets elab)
+ , null (elabTestTargets elab)
+ , null (elabBenchTargets elab)
+ , null (elabReplTarget elab)
+ , null (elabHaddockTargets elab)
+ ]
+ )
-- Note [Sticky enabled testsuites]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3573,11 +3714,11 @@ pruneInstallPlanPass1 pkgs
-- the optional stanzas and we'll make further tweaks to the optional
-- stanzas in the next pass.
--
- pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId]
+ pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [Graph.Key ElaboratedConfiguredPackage]
pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} =
InstallPlan.depends elab -- no pruning
pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} =
- (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)
+ (fold . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)
where
keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas
keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas
@@ -3604,7 +3745,7 @@ pruneInstallPlanPass1 pkgs
availablePkgs =
Set.fromList
- [ installedUnitId pkg
+ [ Graph.nodeKey pkg
| InstallPlan.PreExisting pkg <- pkgs
]
@@ -3640,7 +3781,7 @@ into the repl to uphold the closure property.
-- all of the deps needed for the test suite, we go ahead and
-- enable it always.
optionalStanzasWithDepsAvailable
- :: Set UnitId
+ :: Set (Graph.Key ElaboratedPlanPackage)
-> ElaboratedConfiguredPackage
-> ElaboratedPackage
-> OptionalStanzaSet
@@ -3648,8 +3789,7 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg =
optStanzaSetFromList
[ stanza
| stanza <- optStanzaSetToList (elabStanzasAvailable elab)
- , let deps :: [UnitId]
- deps =
+ , let deps =
CD.select
(optionalStanzaDeps stanza)
-- TODO: probably need to select other
@@ -3742,7 +3882,7 @@ pruneInstallPlanPass2 pkgs =
libTargetsRequiredForRevDeps =
[ c
- | installedUnitId elab `Set.member` hasReverseLibDeps
+ | Graph.nodeKey elab `Set.member` hasReverseLibDeps
, let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent
, -- Don't enable building for anything which is being build in memory
elabBuildStyle elab /= BuildInplaceOnly InMemory
@@ -3757,11 +3897,10 @@ pruneInstallPlanPass2 pkgs =
elabPkgSourceId elab
)
WholeComponent
- | installedUnitId elab `Set.member` hasReverseExeDeps
+ | Graph.nodeKey elab `Set.member` hasReverseExeDeps
]
- availablePkgs :: Set UnitId
- availablePkgs = Set.fromList (map installedUnitId pkgs)
+ availablePkgs = Set.fromList (map Graph.nodeKey pkgs)
inMemoryTargets :: Set ConfiguredId
inMemoryTargets = do
@@ -3771,7 +3910,6 @@ pruneInstallPlanPass2 pkgs =
, BuildInplaceOnly InMemory <- [elabBuildStyle pkg]
]
- hasReverseLibDeps :: Set UnitId
hasReverseLibDeps =
Set.fromList
[ depid
@@ -3779,7 +3917,6 @@ pruneInstallPlanPass2 pkgs =
, depid <- elabOrderLibDependencies pkg
]
- hasReverseExeDeps :: Set UnitId
hasReverseExeDeps =
Set.fromList
[ depid
@@ -3806,21 +3943,21 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =
--
-- This is not always possible.
pruneInstallPlanToDependencies
- :: Set UnitId
+ :: HasCallStack
+ => Set (Graph.Key ElaboratedPlanPackage)
-> ElaboratedInstallPlan
-> Either
CannotPruneDependencies
- ElaboratedInstallPlan
+ (Graph.Graph ElaboratedPlanPackage)
pruneInstallPlanToDependencies pkgTargets installPlan =
assert
( all
(isJust . InstallPlan.lookup installPlan)
(Set.toList pkgTargets)
)
- $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
- . checkBrokenDeps
+ $ checkBrokenDeps
. Graph.fromDistinctList
- . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)
+ . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets)
. InstallPlan.toList
$ installPlan
where
@@ -3840,7 +3977,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
CannotPruneDependencies
[ (pkg, missingDeps)
| (pkg, missingDepIds) <- brokenPackages
- , let missingDeps = mapMaybe lookupDep missingDepIds
+ , let missingDeps = NE.map (fromMaybe (error "should not happen") . lookupDep) missingDepIds
]
where
-- lookup in the original unpruned graph
@@ -3855,7 +3992,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
newtype CannotPruneDependencies
= CannotPruneDependencies
[ ( ElaboratedPlanPackage
- , [ElaboratedPlanPackage]
+ , NonEmpty ElaboratedPlanPackage
)
]
deriving (Show)
@@ -3877,11 +4014,10 @@ setupHsScriptOptions
-> DistDirLayout
-> SymbolicPath CWD (Dir Pkg)
-> SymbolicPath Pkg (Dir Dist)
- -> Bool
-> Lock
-> SetupScriptOptions
-- TODO: Fix this so custom is a separate component. Custom can ALWAYS
--- be a separate component!!!
+-- be a separate component!!! See #9986.
setupHsScriptOptions
(ReadyPackage elab@ElaboratedConfiguredPackage{..})
plan
@@ -3889,7 +4025,6 @@ setupHsScriptOptions
distdir
srcdir
builddir
- isParallelBuild
cacheLock =
SetupScriptOptions
{ useCabalVersion = thisVersion elabSetupScriptCliVersion
@@ -3901,18 +4036,18 @@ setupHsScriptOptions
-- - if we commit to a Cabal version, the logic in
Nothing
else Just elabSetupScriptCliVersion
- , useCompiler = Just pkgConfigCompiler
- , usePlatform = Just pkgConfigPlatform
+ , useCompiler = Just toolchainCompiler
+ , usePlatform = Just toolchainPlatform
+ , useProgramDb = toolchainProgramDb
, usePackageDB = elabSetupPackageDBStack
, usePackageIndex = Nothing
, useDependencies =
- [ (uid, srcid)
- | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <-
- elabSetupDependencies elab
+ [ (confInstId cid, confSrcId cid)
+ | -- TODO: we should filter for dependencies on libraries but that should be implicit in elabSetupLibDependencies
+ (WithStage _ cid) <- elabSetupLibDependencies elab
]
, useDependenciesExclusive = True
, useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps
- , useProgramDb = pkgConfigCompilerProgs
, useDistPref = builddir
, useLoggingHandle = Nothing -- this gets set later
, useWorkingDir = Just srcdir
@@ -3922,7 +4057,6 @@ setupHsScriptOptions
-- for build-tools-depends.
useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan
, useWin32CleanHack = False -- TODO: [required eventually]
- , forceExternalSetupMethod = isParallelBuild
, setupCacheLock = Just cacheLock
, isInteractive = False
, isMainLibOrExeComponent = case elabPkgOrComp of
@@ -3936,6 +4070,10 @@ setupHsScriptOptions
-- everything else is not a main lib or exe component
ElabComponent _ -> False
}
+ where
+ Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} =
+ -- TODO: It is disappointing that we have to change the stage here
+ getStage pkgConfigToolchains (prevStage elabStage)
-- | To be used for the input for elaborateInstallPlan.
--
@@ -3998,20 +4136,21 @@ storePackageInstallDirs'
computeInstallDirs
:: StoreDirLayout
- -> InstallDirs.InstallDirTemplates
+ -> Staged InstallDirs.InstallDirTemplates
-> ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> InstallDirs.InstallDirs FilePath
-computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
- | isInplaceBuildStyle (elabBuildStyle elab) =
- -- use the ordinary default install dirs
+computeInstallDirs storeDirLayout defaultInstallDirs sharedConfig elab =
+ if isInplaceBuildStyle (elabBuildStyle elab)
+ then -- use the ordinary default install dirs
+
( InstallDirs.absoluteInstallDirs
(elabPkgSourceId elab)
(elabUnitId elab)
- (compilerInfo (pkgConfigCompiler elaboratedShared))
+ (compilerInfo toolchainCompiler)
InstallDirs.NoCopyDest
- (pkgConfigPlatform elaboratedShared)
- defaultInstallDirs
+ toolchainPlatform
+ defaultInstallDirs'
)
{ -- absoluteInstallDirs sets these as 'undefined' but we have
-- to use them as "Setup.hs configure" args
@@ -4019,12 +4158,15 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
, InstallDirs.libexecsubdir = ""
, InstallDirs.datasubdir = ""
}
- | otherwise =
- -- use special simplified install dirs
+ else -- use special simplified install dirs
+
storePackageInstallDirs'
storeDirLayout
- (pkgConfigCompiler elaboratedShared)
+ toolchainCompiler
(elabUnitId elab)
+ where
+ Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) (elabStage elab)
+ defaultInstallDirs' = getStage defaultInstallDirs (elabStage elab)
-- TODO: [code cleanup] perhaps reorder this code
-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,
@@ -4042,9 +4184,9 @@ setupHsConfigureFlags
-> m Cabal.ConfigFlags
setupHsConfigureFlags
mkSymbolicPath
- plan
+ _plan
(ReadyPackage elab@ElaboratedConfiguredPackage{..})
- sharedConfig@ElaboratedSharedConfig{..}
+ sharedConfig
configCommonFlags = do
-- explicitly clear, then our package db stack
-- TODO: [required eventually] have to do this differently for older Cabal versions
@@ -4055,6 +4197,8 @@ setupHsConfigureFlags
elab
Cabal.ConfigFlags{..}
where
+ Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage
+
Cabal.ConfigFlags
{ configVanillaLib
, configSharedLib
@@ -4063,7 +4207,7 @@ setupHsConfigureFlags
, configDynExe
, configFullyStaticExe
, configGHCiLib
- , -- , configProfExe -- overridden
+ , -- configProfExe -- overridden
configProfLib
, configProfShared
, -- , configProf -- overridden
@@ -4082,7 +4226,9 @@ setupHsConfigureFlags
configProfExe = mempty
configProf = toFlag $ LBC.withProfExe elabBuildOptions
- configInstantiateWith = Map.toList elabInstantiatedWith
+ configInstantiateWith = case elabPkgOrComp of
+ ElabPackage _ -> mempty
+ ElabComponent comp -> Map.toList (compInstantiatedWith comp)
configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese
configIPID = case elabPkgOrComp of
@@ -4093,29 +4239,9 @@ setupHsConfigureFlags
ElabComponent _ -> toFlag elabComponentId
configProgramPaths = Map.toList elabProgramPaths
- configProgramArgs
- | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True =
- -- workaround for
- --
- -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.
- -- custom Setup.hs scripts calling out to GHC even when going via
- -- @runProgram ghcProgram@, as e.g. happy does in its
- --
- -- (see also )
- --
- -- So for now, let's pass the rather harmless and idempotent
- -- `-hide-all-packages` flag to all invocations (which has
- -- the benefit that every GHC invocation starts with a
- -- consistently well-defined clean slate) until we find a
- -- better way.
- Map.toList $
- Map.insertWith
- (++)
- "ghc"
- ["-hide-all-packages"]
- elabProgramArgs
+ configProgramArgs = Map.toList elabProgramArgs
configProgramPathExtra = toNubList elabProgramPathExtra
- configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler)
+ configHcFlavor = toFlag (compilerFlavor toolchainCompiler)
configHcPath = mempty -- we use configProgramPaths instead
configHcPkg = mempty -- we use configProgramPaths instead
configDumpBuildInfo = toFlag elabDumpBuildInfo
@@ -4126,8 +4252,8 @@ setupHsConfigureFlags
configExtraLibDirsStatic = fmap makeSymbolicPath elabExtraLibDirsStatic
configExtraFrameworkDirs = fmap makeSymbolicPath elabExtraFrameworkDirs
configExtraIncludeDirs = fmap makeSymbolicPath elabExtraIncludeDirs
- configProgPrefix = maybe mempty toFlag elabProgPrefix
- configProgSuffix = maybe mempty toFlag elabProgSuffix
+ configProgPrefix = maybe (Flag (Cabal.toPathTemplate "")) toFlag elabProgPrefix
+ configProgSuffix = maybe (Flag (Cabal.toPathTemplate "")) toFlag elabProgSuffix
configInstallDirs =
fmap
@@ -4140,29 +4266,33 @@ setupHsConfigureFlags
-- dependencies which should NOT be fed in here (also you don't have
-- enough info anyway)
--
+ -- FIXME: stage?
configDependencies =
[ cidToGivenComponent cid
- | (cid, is_internal) <- elabLibDependencies elab
+ | (WithStage _stage cid, is_internal) <- elabLibDependencies elab
, not is_internal
]
+ -- FIXME: stage?
configPromisedDependencies =
[ cidToPromisedComponent cid
- | (cid, is_internal) <- elabLibDependencies elab
+ | (WithStage _stage cid, is_internal) <- elabLibDependencies elab
, is_internal
]
+ -- FIXME: stage?
configConstraints =
case elabPkgOrComp of
ElabPackage _ ->
[ thisPackageVersionConstraint srcid
- | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab
+ | (WithStage _stage (ConfiguredId srcid _ _uid), _) <- elabLibDependencies elab
]
ElabComponent _ -> []
configTests = case elabPkgOrComp of
ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)
ElabComponent _ -> mempty
+
configBenchmarks = case elabPkgOrComp of
ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)
ElabComponent _ -> mempty
@@ -4173,7 +4303,7 @@ setupHsConfigureFlags
configUserInstall = mempty -- don't rely on defaults
configPrograms_ = mempty -- never use, shouldn't exist
configUseResponseFiles = mempty
- configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler
+ configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported toolchainCompiler
configIgnoreBuildTools = mempty
cidToGivenComponent :: ConfiguredId -> GivenComponent
@@ -4184,7 +4314,9 @@ setupHsConfigureFlags
Just _ -> error "non-library dependency"
Nothing -> LMainLibName
- configCoverageFor = determineCoverageFor elab plan
+ -- FIXME: whathever
+ -- configCoverageFor = determineCoverageFor elab plan
+ configCoverageFor = NoFlag
cidToPromisedComponent :: ConfiguredId -> PromisedComponent
cidToPromisedComponent (ConfiguredId srcid mb_cn cid) =
@@ -4211,15 +4343,16 @@ setupHsCommonFlags
:: Verbosity
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> SymbolicPath Pkg (Dir Dist)
+ -> [String]
-> Bool
-> Cabal.CommonSetupFlags
-setupHsCommonFlags verbosity mbWorkDir builddir keepTempFiles =
+setupHsCommonFlags verbosity mbWorkDir builddir targets keepTempFiles =
Cabal.CommonSetupFlags
{ setupDistPref = toFlag builddir
, setupVerbosity = toFlag $ verbosityFlags verbosity
, setupCabalFilePath = mempty
, setupWorkingDir = maybeToFlag mbWorkDir
- , setupTargets = []
+ , setupTargets = targets
, setupKeepTempFiles = toFlag keepTempFiles
}
@@ -4259,11 +4392,11 @@ setupHsTestFlags
setupHsTestFlags (ElaboratedConfiguredPackage{..}) common =
Cabal.TestFlags
{ testCommonFlags = common
- , testMachineLog = maybe mempty toFlag elabTestMachineLog
- , testHumanLog = maybe mempty toFlag elabTestHumanLog
+ , testMachineLog = maybeToFlag elabTestMachineLog
+ , testHumanLog = maybeToFlag elabTestHumanLog
, testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails
, testKeepTix = toFlag elabTestKeepTix
- , testWrapper = maybe mempty toFlag elabTestWrapper
+ , testWrapper = maybeToFlag elabTestWrapper
, testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites
, testOptions = elabTestTestOptions
}
@@ -4348,13 +4481,13 @@ setupHsHaddockFlags
-> Cabal.HaddockFlags
setupHsHaddockFlags
(ElaboratedConfiguredPackage{..})
- (ElaboratedSharedConfig{..})
+ sharedConfig
_buildTimeSettings
common =
Cabal.HaddockFlags
{ haddockCommonFlags = common
, haddockProgramPaths =
- case lookupProgram haddockProgram pkgConfigCompilerProgs of
+ case lookupProgram haddockProgram toolchainProgramDb of
Nothing -> mempty
Just prg ->
[
@@ -4365,24 +4498,26 @@ setupHsHaddockFlags
, haddockProgramArgs = mempty -- unused, set at configure time
, haddockHoogle = toFlag elabHaddockHoogle
, haddockHtml = toFlag elabHaddockHtml
- , haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation
+ , haddockHtmlLocation = maybeToFlag elabHaddockHtmlLocation
, haddockForHackage = toFlag elabHaddockForHackage
, haddockForeignLibs = toFlag elabHaddockForeignLibs
, haddockExecutables = toFlag elabHaddockExecutables
, haddockTestSuites = toFlag elabHaddockTestSuites
, haddockBenchmarks = toFlag elabHaddockBenchmarks
, haddockInternal = toFlag elabHaddockInternal
- , haddockCss = maybe mempty toFlag elabHaddockCss
+ , haddockCss = maybeToFlag elabHaddockCss
, haddockLinkedSource = toFlag elabHaddockLinkedSource
, haddockQuickJump = toFlag elabHaddockQuickJump
- , haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss
- , haddockContents = maybe mempty toFlag elabHaddockContents
+ , haddockHscolourCss = maybeToFlag elabHaddockHscolourCss
+ , haddockContents = maybeToFlag elabHaddockContents
, haddockIndex = maybe mempty toFlag elabHaddockIndex
, haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl
, haddockResourcesDir = maybe mempty toFlag elabHaddockResourcesDir
, haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir
, haddockUseUnicode = toFlag elabHaddockUseUnicode
}
+ where
+ Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains sharedConfig) elabStage
setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String]
-- TODO: Does the issue #3335 affects test as well
@@ -4445,33 +4580,39 @@ packageHashInputs
) =
PackageHashInputs
{ pkgHashPkgId = packageId elab
- , pkgHashComponent =
- case elabPkgOrComp elab of
- ElabPackage _ -> Nothing
- ElabComponent comp -> Just (compSolverName comp)
+ , pkgHashComponent
, pkgHashSourceHash = srchash
, pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab)
- , pkgHashDirectDeps =
- case elabPkgOrComp elab of
- ElabPackage (ElaboratedPackage{..}) ->
- Set.fromList $
- [ confInstId dep
- | (dep, _) <- CD.select relevantDeps pkgLibDependencies
- ]
- ++ [ confInstId dep
- | dep <- CD.select relevantDeps pkgExeDependencies
- ]
- ElabComponent comp ->
- Set.fromList
- ( map
- confInstId
- ( map fst (compLibDependencies comp)
- ++ compExeDependencies comp
- )
- )
+ , pkgHashLibDeps
+ , pkgHashExeDeps
, pkgHashOtherConfig = packageHashConfigInputs pkgshared elab
}
where
+ pkgHashComponent =
+ case elabPkgOrComp elab of
+ ElabPackage _ -> Nothing
+ ElabComponent comp -> Just (compSolverName comp)
+ pkgHashLibDeps =
+ case elabPkgOrComp elab of
+ ElabPackage (ElaboratedPackage{..}) ->
+ Set.fromList
+ [confInstId c | (c, _promised) <- CD.select relevantDeps pkgLibDependencies]
+ ElabComponent comp ->
+ Set.fromList
+ [confInstId c | (c, _promised) <- compLibDependencies comp]
+ pkgHashExeDeps =
+ case elabPkgOrComp elab of
+ ElabPackage (ElaboratedPackage{..}) ->
+ Set.fromList
+ [ confInstId c
+ | WithStage _stage c <- CD.select relevantDeps pkgExeDependencies
+ ]
+ ElabComponent comp ->
+ Set.fromList
+ [ confInstId c
+ | WithStage _stage c <- compExeDependencies comp
+ ]
+
-- Obviously the main deps are relevant
relevantDeps CD.ComponentLib = True
relevantDeps (CD.ComponentSubLib _) = True
@@ -4492,11 +4633,11 @@ packageHashConfigInputs
:: ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> PackageHashConfigInputs
-packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =
+packageHashConfigInputs sharedConfig pkg =
PackageHashConfigInputs
- { pkgHashCompilerId = compilerId pkgConfigCompiler
- , pkgHashCompilerABI = compilerAbiTag pkgConfigCompiler
- , pkgHashPlatform = pkgConfigPlatform
+ { pkgHashCompilerId = compilerId toolchainCompiler
+ , pkgHashCompilerABI = compilerAbiTag toolchainCompiler
+ , pkgHashPlatform = toolchainPlatform
, pkgHashFlagAssignment = elabFlagAssignment
, pkgHashConfigureScriptArgs = elabConfigureScriptArgs
, pkgHashVanillaLib = withVanillaLib
@@ -4544,22 +4685,10 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =
, pkgHashHaddockUseUnicode = elabHaddockUseUnicode
}
where
- ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg
+ Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) elabStage
+ ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage sharedConfig pkg
LBC.BuildOptions{..} = elabBuildOptions
--- | Given the 'InstalledPackageIndex' for a nix-style package store, and an
--- 'ElaboratedInstallPlan', replace configured source packages by installed
--- packages from the store whenever they exist.
-improveInstallPlanWithInstalledPackages
- :: Set UnitId
- -> ElaboratedInstallPlan
- -> ElaboratedInstallPlan
-improveInstallPlanWithInstalledPackages installedPkgIdSet =
- InstallPlan.installed canPackageBeImproved
- where
- canPackageBeImproved pkg =
- installedUnitId pkg `Set.member` installedPkgIdSet
-
-- TODO: sanity checks:
-- \* the installed package must have the expected deps etc
-- \* the installed package must not be broken, valid dep closure
@@ -4601,43 +4730,121 @@ inplaceBinRoot layout config package =
distBuildDirectory layout (elabDistDirParams config package)
"build"
---------------------------------------------------------------------------------
--- Configure --coverage-for flags
+-- FIXME: whathever
+-- --------------------------------------------------------------------------------
+-- -- Configure --coverage-for flags
-- The list of non-pre-existing libraries without module holes, i.e. the
-- main library and sub-libraries components of all the local packages in
-- the project that are dependencies of the components being built and that do
-- not require instantiations or are instantiations.
-determineCoverageFor
- :: ElaboratedConfiguredPackage
- -- ^ The package or component being configured
- -> ElaboratedInstallPlan
- -> Flag [UnitId]
-determineCoverageFor configuredPkg plan =
- Flag
- $ mapMaybe
- ( \case
- InstallPlan.Installed elab
- | shouldCoverPkg elab -> Just $ elabUnitId elab
- InstallPlan.Configured elab
- | shouldCoverPkg elab -> Just $ elabUnitId elab
- _ -> Nothing
- )
- $ Graph.toList
- $ InstallPlan.toGraph plan
- where
- libDeps = elabLibDependencies configuredPkg
- shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} =
- elabLocalToProject
- && not (isIndefiniteOrInstantiation elabModuleShape)
- -- TODO(#9493): We can only cover libraries in the same package
- -- as the testsuite
- && elabPkgSourceId configuredPkg == pkgSID
- -- Libraries only! We don't cover testsuite modules, so we never need
- -- the paths to their mix dirs. Furthermore, we do not install testsuites...
- && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab)
- -- We only want coverage for libraries which are dependencies of the given one
- && pkgSID `elem` map (confSrcId . fst) libDeps
-
- isIndefiniteOrInstantiation :: ModuleShape -> Bool
- isIndefiniteOrInstantiation = not . Set.null . modShapeRequires
+-- determineCoverageFor
+-- :: ElaboratedConfiguredPackage
+-- -- ^ The package or component being configured
+-- -> ElaboratedInstallPlan
+-- -> Flag [UnitId]
+-- determineCoverageFor configuredPkg plan =
+-- Flag
+-- $ mapMaybe
+-- ( \case
+-- InstallPlan.Installed elab
+-- | shouldCoverPkg elab -> Just $ elabUnitId elab
+-- InstallPlan.Configured elab
+-- | shouldCoverPkg elab -> Just $ elabUnitId elab
+-- _ -> Nothing
+-- )
+-- $ Graph.toList
+-- $ InstallPlan.toGraph plan
+-- where
+-- libDeps = elabLibDependencies configuredPkg
+-- shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} =
+-- elabLocalToProject
+-- && not (isIndefiniteOrInstantiation elabModuleShape)
+-- -- TODO(#9493): We can only cover libraries in the same package
+-- -- as the testsuite
+-- && elabPkgSourceId configuredPkg == pkgSID
+-- -- Libraries only! We don't cover testsuite modules, so we never need
+-- -- the paths to their mix dirs. Furthermore, we do not install testsuites...
+-- && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab)
+-- -- We only want coverage for libraries which are dependencies of the given one
+-- && pkgSID `elem` map (confSrcId . fst) libDeps
+
+-- isIndefiniteOrInstantiation :: ModuleShape -> Bool
+-- isIndefiniteOrInstantiation = not . Set.null . modShapeRequires
+
+-- While we can talk to older Cabal versions (we need to be able to
+-- do so for custom Setup scripts that require older Cabal lib
+-- versions), we have problems talking to some older versions that
+-- don't support certain features.
+--
+-- For example, Cabal-1.16 and older do not know about build targets.
+-- Even worse, 1.18 and older only supported the --constraint flag
+-- with source package ids, not --dependency with installed package
+-- ids. That is bad because we cannot reliably select the right
+-- dependencies in the presence of multiple instances (i.e. the
+-- store). See issue #3932. So we require Cabal 1.20 as a minimum.
+--
+-- Moreover, lib:Cabal generally only supports the interface of
+-- current and past compilers; in fact recent lib:Cabal versions
+-- will warn when they encounter a too new or unknown GHC compiler
+-- version (c.f. #415). To avoid running into unsupported
+-- configurations we encode the compatibility matrix as lower
+-- bounds on lib:Cabal here (effectively corresponding to the
+-- respective major Cabal version bundled with the respective GHC
+-- release).
+--
+-- GHC 9.2 needs Cabal >= 3.6
+-- GHC 9.0 needs Cabal >= 3.4
+-- GHC 8.10 needs Cabal >= 3.2
+-- GHC 8.8 needs Cabal >= 3.0
+-- GHC 8.6 needs Cabal >= 2.4
+-- GHC 8.4 needs Cabal >= 2.2
+-- GHC 8.2 needs Cabal >= 2.0
+-- GHC 8.0 needs Cabal >= 1.24
+-- GHC 7.10 needs Cabal >= 1.22
+--
+-- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is
+-- the absolute lower bound)
+--
+-- TODO: long-term, this compatibility matrix should be
+-- stored as a field inside 'Distribution.Compiler.Compiler'
+--
+-- setupMinCabalVersionConstraint :: Compiler -> Version
+-- setupMinCabalVersionConstraint compiler
+-- | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12]
+-- | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10]
+-- | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8]
+-- | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6]
+-- | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4]
+-- | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2]
+-- | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0]
+-- | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4]
+-- | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2]
+-- | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0]
+-- | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24]
+-- | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22]
+-- | otherwise = mkVersion [1, 20]
+-- where
+-- isGHC = compFlav `elem` [GHC, GHCJS]
+-- compFlav = compilerFlavor compiler
+-- compVer = compilerVersion compiler
+
+-- As we can't predict the future, we also place a global upper
+-- bound on the lib:Cabal version we know how to interact with:
+--
+-- The upper bound is computed by incrementing the current major
+-- version twice in order to allow for the current version, as
+-- well as the next adjacent major version (one of which will not
+-- be released, as only "even major" versions of Cabal are
+-- released to Hackage or bundled with proper GHC releases).
+--
+-- For instance, if the current version of cabal-install is an odd
+-- development version, e.g. Cabal-2.1.0.0, then we impose an
+-- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a
+-- stable/release even version, e.g. Cabal-2.2.1.0, the upper
+-- bound is `setup.Cabal < 2.4`. This gives us enough flexibility
+-- when dealing with development snapshots of Cabal and cabal-install.
+--
+-- setupMaxCabalVersionConstraint :: Version
+-- setupMaxCabalVersionConstraint =
+-- alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs
index 0ef3b872286..e3a6595ecdb 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs
@@ -237,9 +237,5 @@ legacyCustomSetupPkgs compiler (Platform _ os) =
++ ["unix" | os /= Windows]
++ ["ghc-prim" | isGHC]
++ ["template-haskell" | isGHC]
- ++ ["old-time" | notGHC710]
where
isGHC = compilerCompatFlavor GHC compiler
- notGHC710 = case compilerCompatVersion GHC compiler of
- Nothing -> False
- Just v -> v <= mkVersion [7, 9]
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs
new file mode 100644
index 00000000000..d2a5f186e18
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Client.ProjectPlanning.Stage
+ ( WithStage (..)
+ , Stage (..)
+ , HasStage (..)
+ , Staged (..)
+ ) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.Client.Types.ConfiguredId (HasConfiguredId (..))
+import Distribution.Compat.Graph (IsNode (..))
+import Distribution.Package (HasUnitId (..), Package (..))
+import Distribution.Solver.Types.Stage (Stage (..), Staged (..))
+import Text.PrettyPrint (colon)
+
+-- FIXME: blaaah
+data WithStage a = WithStage Stage a
+ deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
+
+instance Binary a => Binary (WithStage a)
+instance Structured a => Structured (WithStage a)
+
+instance Package pkg => Package (WithStage pkg) where
+ packageId (WithStage _stage pkg) = packageId pkg
+
+instance IsNode a => IsNode (WithStage a) where
+ type Key (WithStage a) = WithStage (Key a)
+ nodeKey = fmap nodeKey
+ nodeNeighbors = traverse nodeNeighbors
+
+instance HasUnitId a => HasUnitId (WithStage a) where
+ installedUnitId (WithStage _stage pkg) = installedUnitId pkg
+
+instance HasConfiguredId a => HasConfiguredId (WithStage a) where
+ configuredId (WithStage _stage pkg) = configuredId pkg
+
+instance Pretty a => Pretty (WithStage a) where
+ pretty (WithStage s pkg) = pretty s <> colon <> pretty pkg
+
+class HasStage a where
+ stageOf :: a -> Stage
+
+instance HasStage (WithStage a) where
+ stageOf (WithStage s _) = s
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
index 09400582074..3588d0719ff 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
@@ -14,6 +15,7 @@ module Distribution.Client.ProjectPlanning.Types
-- * Elaborated install plan types
, ElaboratedInstallPlan
, normaliseConfiguredPackage
+ , ElaboratedInstalledPackageInfo
, ElaboratedConfiguredPackage (..)
, showElaboratedInstallPlan
, elabDistDirParams
@@ -22,7 +24,7 @@ module Distribution.Client.ProjectPlanning.Types
, elabOrderLibDependencies
, elabExeDependencies
, elabOrderExeDependencies
- , elabSetupDependencies
+ , elabSetupLibDependencies
, elabPkgConfigDependencies
, elabInplaceDependencyBuildCacheFiles
, elabRequiresRegistration
@@ -59,6 +61,15 @@ module Distribution.Client.ProjectPlanning.Types
, componentOptionalStanza
, componentTargetName
+ -- * Toolchain
+ , Toolchain (..)
+ , Toolchains
+ , Stage (..)
+ , Staged (..)
+ , WithStage (..)
+ , withStage
+ , HasStage (..)
+
-- * Setup script
, SetupScriptStyle (..)
) where
@@ -77,9 +88,11 @@ import Distribution.Client.InstallPlan
, GenericPlanPackage (..)
)
import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.ProjectPlanning.Stage
import Distribution.Client.SolverInstallPlan
( SolverInstallPlan
)
+import Distribution.Client.Toolchain
import Distribution.Client.Types
import Distribution.Backpack
@@ -110,21 +123,21 @@ import Distribution.Simple.Utils (ordNub)
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.OptionalStanza
-import Distribution.System
import Distribution.Types.ComponentRequestedSpec
import qualified Distribution.Types.LocalBuildConfig as LBC
import Distribution.Types.PackageDescription (PackageDescription (..))
import Distribution.Types.PkgconfigVersion
import Distribution.Utils.Path (getSymbolicPath)
+import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel)
import Distribution.Version
import qualified Data.ByteString.Lazy as LBS
+import Data.Foldable (fold)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
-import qualified Data.Monoid as Mon
-import Distribution.Verbosity
+import qualified Distribution.Compat.Graph as Graph
import System.FilePath (())
-import Text.PrettyPrint (hsep, parens, text)
+import Text.PrettyPrint (colon, hsep, parens, text)
-- | The combination of an elaborated install plan plus a
-- 'ElaboratedSharedConfig' contains all the details necessary to be able
@@ -134,14 +147,27 @@ import Text.PrettyPrint (hsep, parens, text)
-- connections).
type ElaboratedInstallPlan =
GenericInstallPlan
- InstalledPackageInfo
+ ElaboratedInstalledPackageInfo
ElaboratedConfiguredPackage
type ElaboratedPlanPackage =
GenericPlanPackage
- InstalledPackageInfo
+ ElaboratedInstalledPackageInfo
ElaboratedConfiguredPackage
+instance HasStage ElaboratedPlanPackage where
+ stageOf (PreExisting ipkg) = stageOf ipkg
+ stageOf (Configured srcpkg) = stageOf srcpkg
+ stageOf (Installed srcpkg) = stageOf srcpkg
+
+instance HasStage ElaboratedPackage where
+ stageOf = pkgStage
+
+withStage :: HasStage a => a -> WithStage a
+withStage a = WithStage (stageOf a) a
+
+type ElaboratedInstalledPackageInfo = WithStage InstalledPackageInfo
+
-- | User-friendly display string for an 'ElaboratedPlanPackage'.
elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String
elabPlanPackageName verbosity (PreExisting ipkg)
@@ -155,6 +181,7 @@ elabPlanPackageName verbosity (Installed elab) =
showElaboratedInstallPlan :: ElaboratedInstallPlan -> String
showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode
where
+ showNode :: ElaboratedPlanPackage -> InstallPlan.ShowPlanNode
showNode pkg =
InstallPlan.ShowPlanNode
{ InstallPlan.showPlanHerald = herald
@@ -163,7 +190,7 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode
where
herald =
( hsep
- [ text (InstallPlan.showPlanPackageTag pkg)
+ [ InstallPlan.renderPlanPackageTag pkg
, InstallPlan.foldPlanPackage (const mempty) in_mem pkg
, pretty (packageId pkg)
, parens (pretty (nodeKey pkg))
@@ -178,15 +205,16 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode
installed_deps = map pretty . nodeNeighbors
- local_deps cfg = [(if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg]
+ local_deps cfg =
+ [ (if internal then text "+" else mempty) <> pretty s <> colon <> pretty (confInstId uid)
+ | (WithStage s uid, internal) <- elabLibDependencies cfg
+ ]
-- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle
-- even platform and compiler could be different if we're building things
-- like a server + client with ghc + ghcjs
data ElaboratedSharedConfig = ElaboratedSharedConfig
- { pkgConfigPlatform :: Platform
- , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo
- , pkgConfigCompilerProgs :: ProgramDb
+ { pkgConfigToolchains :: Toolchains
-- ^ The programs that the compiler configured (e.g. for GHC, the progs
-- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are
-- used.
@@ -203,8 +231,6 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
{ elabUnitId :: UnitId
-- ^ The 'UnitId' which uniquely identifies this item in a build plan
, elabComponentId :: ComponentId
- , elabInstantiatedWith :: Map ModuleName Module
- , elabLinkedInstantiatedWith :: Map ModuleName OpenModule
, elabIsCanonical :: Bool
-- ^ This is true if this is an indefinite package, or this is a
-- package with no signatures. (Notably, it's not true for instantiated
@@ -223,6 +249,8 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
, elabFlagDefaults :: Cabal.FlagAssignment
-- ^ The original default flag assignment, used only for reporting.
, elabPkgDescription :: Cabal.PackageDescription
+ , elabGPkgDescription :: Cabal.GenericPackageDescription
+ -- ^ Original 'GenericPackageDescription' (just used to report errors/warnings)
, elabPkgSourceLocation :: PackageLocation (Maybe FilePath)
-- ^ Where the package comes from, e.g. tarball, local dir etc. This
-- is not the same as where it may be unpacked to for the build.
@@ -247,21 +275,21 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
-- to disable. This tells us which ones we build by default, and
-- helps with error messages when the user asks to build something
-- they explicitly disabled.
- --
- -- TODO: The 'Bool' here should be refined into an ADT with three
- -- cases: NotRequested, ExplicitlyRequested and
- -- ImplicitlyRequested. A stanza is explicitly requested if
- -- the user asked, for this *specific* package, that the stanza
- -- be enabled; it's implicitly requested if the user asked for
- -- all global packages to have this stanza enabled. The
- -- difference between an explicit and implicit request is
- -- error reporting behavior: if a user asks for tests to be
- -- enabled for a specific package that doesn't have any tests,
- -- we should warn them about it, but we shouldn't complain
- -- that a user enabled tests globally, and some local packages
- -- just happen not to have any tests. (But perhaps we should
- -- warn if ALL local packages don't have any tests.)
- , elabPackageDbs :: [Maybe PackageDBCWD]
+ , elabStage :: Stage
+ , -- TODO: The 'Bool' here should be refined into an ADT with three
+ -- cases: NotRequested, ExplicitlyRequested and
+ -- ImplicitlyRequested. A stanza is explicitly requested if
+ -- the user asked, for this *specific* package, that the stanza
+ -- be enabled; it's implicitly requested if the user asked for
+ -- all global packages to have this stanza enabled. The
+ -- difference between an explicit and implicit request is
+ -- error reporting behavior: if a user asks for tests to be
+ -- enabled for a specific package that doesn't have any tests,
+ -- we should warn them about it, but we shouldn't complain
+ -- that a user enabled tests globally, and some local packages
+ -- just happen not to have any tests. (But perhaps we should
+ -- warn if ALL local packages don't have any tests.)
+ elabPackageDbs :: [PackageDBCWD]
, elabSetupPackageDBStack :: PackageDBStackCWD
, elabBuildPackageDBStack :: PackageDBStackCWD
, elabRegisterPackageDBStack :: PackageDBStackCWD
@@ -344,10 +372,11 @@ normaliseConfiguredPackage
:: ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> ElaboratedConfiguredPackage
-normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =
+normaliseConfiguredPackage shared pkg =
pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)}
where
- knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs
+ Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains shared) (elabStage pkg)
+ knownProgramDb = addKnownPrograms builtinPrograms toolchainProgramDb
pkgDesc :: PackageDescription
pkgDesc = elabPkgDescription pkg
@@ -493,10 +522,14 @@ instance HasUnitId ElaboratedConfiguredPackage where
installedUnitId = elabUnitId
instance IsNode ElaboratedConfiguredPackage where
- type Key ElaboratedConfiguredPackage = UnitId
- nodeKey = elabUnitId
+ type Key ElaboratedConfiguredPackage = WithStage UnitId
+ nodeKey elab = WithStage (elabStage elab) (elabUnitId elab)
nodeNeighbors = elabOrderDependencies
+instance HasStage ElaboratedConfiguredPackage where
+ stageOf :: ElaboratedConfiguredPackage -> Stage
+ stageOf = elabStage
+
instance Binary ElaboratedConfiguredPackage
instance Structured ElaboratedConfiguredPackage
@@ -526,23 +559,35 @@ elabConfiguredName verbosity elab
Just (CLibName LMainLibName) -> ""
Just cname -> prettyShow cname ++ " from "
)
- ++ prettyShow (packageId elab)
+ ++ prettyShow (Graph.nodeKey elab)
| otherwise =
prettyShow (elabUnitId elab)
elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams shared elab =
DistDirParams
- { distParamUnitId = installedUnitId elab
+ { distParamStage = elabStage elab
+ , distParamUnitId = installedUnitId elab
, distParamComponentId = elabComponentId elab
, distParamPackageId = elabPkgSourceId elab
, distParamComponentName = case elabPkgOrComp elab of
ElabComponent comp -> compComponentName comp
ElabPackage _ -> Nothing
- , distParamCompilerId = compilerId (pkgConfigCompiler shared)
- , distParamPlatform = pkgConfigPlatform shared
+ , distParamCompilerId = compilerId toolchainCompiler
+ , distParamPlatform = toolchainPlatform
, distParamOptimization = LBC.withOptimization $ elabBuildOptions elab
}
+ where
+ Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab)
+
+--
+-- Order dependencies
+--
+-- Order dependencies are identified by their 'UnitId' and only used to define the
+-- dependency relationships in the build graph. In particular they do not provide
+-- any other information needed to build the component or package. We can consider
+-- UnitId as a opaque identifier.
+--
-- | The full set of dependencies which dictate what order we
-- need to build things in the install plan: "order dependencies"
@@ -552,49 +597,81 @@ elabDistDirParams shared elab =
-- use 'elabLibDependencies'. This method is the same as
-- 'nodeNeighbors'.
--
--- NB: this method DOES include setup deps.
-elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId]
+-- Note: this method DOES include setup deps.
+elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId]
elabOrderDependencies elab =
- case elabPkgOrComp elab of
- -- Important not to have duplicates: otherwise InstallPlan gets
- -- confused.
- ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))
- ElabComponent comp -> compOrderDependencies comp
-
--- | Like 'elabOrderDependencies', but only returns dependencies on
--- libraries.
-elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId]
+ elabOrderLibDependencies elab <> elabOrderExeDependencies elab
+
+-- | The result includes setup dependencies
+elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId]
elabOrderLibDependencies elab =
case elabPkgOrComp elab of
ElabPackage pkg ->
- map (newSimpleUnitId . confInstId) $
- ordNub $
- CD.flatDeps (map fst <$> pkgLibDependencies pkg)
- ElabComponent comp -> compOrderLibDependencies comp
-
--- | The library dependencies (i.e., the libraries we depend on, NOT
--- the dependencies of the library), NOT including setup dependencies.
--- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@.
-elabLibDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)]
-elabLibDependencies elab =
+ -- Note: flatDeps include the setup dependencies too
+ ordNub $ concatMap snd . CD.toList $ (pkgOrderLibDependencies pkg)
+ ElabComponent comp ->
+ map (WithStage (elabStage elab)) (compOrderLibDependencies comp)
+
+-- | The result includes setup dependencies
+elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId]
+elabOrderExeDependencies elab =
case elabPkgOrComp elab of
- ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg))
- ElabComponent comp -> compLibDependencies comp
+ ElabPackage pkg ->
+ ordNub $ concatMap snd . CD.toList $ (pkgOrderExeDependencies pkg)
+ ElabComponent comp ->
+ map (fmap fromConfiguredId) (compExeDependencies comp)
--- | Like 'elabOrderDependencies', but only returns dependencies on
--- executables. (This coincides with 'elabExeDependencies'.)
-elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId]
-elabOrderExeDependencies =
- map newSimpleUnitId . elabExeDependencies
+-- | See 'elabOrderDependencies'. This gives the unflattened version,
+-- which can be useful in some circumstances.
+pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId]
+pkgOrderDependencies pkg =
+ pkgOrderLibDependencies pkg <> pkgOrderExeDependencies pkg
+
+pkgOrderLibDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId]
+pkgOrderLibDependencies pkg =
+ CD.fromList
+ [ (comp, map (WithStage stage . fromConfiguredId . fst) deps)
+ | (comp, deps) <- CD.toList (pkgLibDependencies pkg)
+ , let stage =
+ if comp == CD.ComponentSetup
+ then prevStage (pkgStage pkg)
+ else pkgStage pkg
+ ]
+
+pkgOrderExeDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId]
+pkgOrderExeDependencies pkg =
+ fmap (map (fmap fromConfiguredId)) $
+ pkgExeDependencies pkg
+
+fromConfiguredId :: ConfiguredId -> UnitId
+fromConfiguredId = newSimpleUnitId . confInstId
+
+--- | Library dependencies.
+---
+--- These are identified by their 'ConfiguredId' and are passed to the @Setup@
+--- script via @--dependency@ or @--promised-dependency@.
+--- Note that setup dependencies (meaning the library dependencies of the setup
+-- script) are not included here, they are handled separately.
+elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)]
+elabLibDependencies elab =
+ -- Library dependencies are always in the same stage as the component/package we are
+ -- building.
+ map (\(cid, promised) -> (WithStage (elabStage elab) cid, promised)) $
+ case elabPkgOrComp elab of
+ ElabPackage pkg ->
+ ordNub $ CD.nonSetupDeps (pkgLibDependencies pkg)
+ ElabComponent comp ->
+ compLibDependencies comp
-- | The executable dependencies (i.e., the executables we depend on);
-- these are the executables we must add to the PATH before we invoke
-- the setup script.
-elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId]
-elabExeDependencies elab = map confInstId $
- case elabPkgOrComp elab of
- ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg)
- ElabComponent comp -> compExeDependencies comp
+elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId]
+elabExeDependencies elab =
+ map (fmap confInstId) $
+ case elabPkgOrComp elab of
+ ElabPackage pkg -> ordNub $ CD.nonSetupDeps (pkgExeDependencies pkg)
+ ElabComponent comp -> compExeDependencies comp
-- | This returns the paths of all the executables we depend on; we
-- must add these paths to PATH before invoking the setup script.
@@ -603,25 +680,33 @@ elabExeDependencies elab = map confInstId $
elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath]
elabExeDependencyPaths elab =
case elabPkgOrComp elab of
- ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg)
+ ElabPackage pkg -> ordNub $ map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg)
ElabComponent comp -> map snd (compExeDependencyPaths comp)
--- | The setup dependencies (the library dependencies of the setup executable;
--- note that it is not legal for setup scripts to have executable
--- dependencies at the moment.)
-elabSetupDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)]
-elabSetupDependencies elab =
+elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)]
+elabPkgConfigDependencies elab =
+ case elabPkgOrComp elab of
+ ElabPackage pkg -> pkgPkgConfigDependencies pkg
+ ElabComponent comp -> compPkgConfigDependencies comp
+
+-- | The setup dependencies (i.e. the library dependencies of the setup executable)
+-- Note that it is not legal for setup scripts to have executable dependencies.
+-- TODO: In that case we should probably not have this function at all, and
+-- only use pkgSetupLibDependencies
+elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [WithStage ConfiguredId]
+elabSetupLibDependencies elab =
case elabPkgOrComp elab of
- ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg)
- -- TODO: Custom setups not supported for components yet. When
- -- they are, need to do this differently
+ ElabPackage pkg -> pkgSetupLibDependencies pkg
+ -- Custom setups not supported for components.
ElabComponent _ -> []
-elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)]
-elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} =
- pkgPkgConfigDependencies pkg
-elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} =
- compPkgConfigDependencies comp
+pkgSetupLibDependencies :: ElaboratedPackage -> [WithStage ConfiguredId]
+pkgSetupLibDependencies pkg =
+ map (WithStage stage . fst) $
+ ordNub $
+ CD.setupDeps (pkgLibDependencies pkg)
+ where
+ stage = prevStage (pkgStage pkg)
-- | The cache files of all our inplace dependencies which,
-- when updated, require us to rebuild. See #4202 for
@@ -683,18 +768,20 @@ data ElaboratedComponent = ElaboratedComponent
-- instantiation phase. It's more precise than
-- 'compLibDependencies', and also stores information about internal
-- dependencies.
- , compExeDependencies :: [ConfiguredId]
+ , compInstantiatedWith :: Map ModuleName Module
+ , compLinkedInstantiatedWith :: Map ModuleName OpenModule
+ , compExeDependencies :: [WithStage ConfiguredId]
-- ^ The executable dependencies of this component (including
-- internal executables).
, compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)]
-- ^ The @pkg-config@ dependencies of the component
- , compExeDependencyPaths :: [(ConfiguredId, FilePath)]
+ , compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)]
-- ^ The paths all our executable dependencies will be installed
-- to once they are installed.
, compOrderLibDependencies :: [UnitId]
-- ^ The UnitIds of the libraries (identifying elaborated packages/
-- components) that must be built before this project. This
- -- is used purely for ordering purposes. It can contain both
+ -- is used purely for ordering purposes. It can contain both
-- references to definite and indefinite packages; an indefinite
-- UnitId indicates that we must typecheck that indefinite package
-- before we can build this one.
@@ -704,18 +791,9 @@ data ElaboratedComponent = ElaboratedComponent
instance Binary ElaboratedComponent
instance Structured ElaboratedComponent
--- | See 'elabOrderDependencies'.
-compOrderDependencies :: ElaboratedComponent -> [UnitId]
-compOrderDependencies comp =
- compOrderLibDependencies comp
- ++ compOrderExeDependencies comp
-
--- | See 'elabOrderExeDependencies'.
-compOrderExeDependencies :: ElaboratedComponent -> [UnitId]
-compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies
-
data ElaboratedPackage = ElaboratedPackage
- { pkgInstalledId :: InstalledPackageId
+ { pkgStage :: Stage
+ , pkgInstalledId :: InstalledPackageId
, pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)]
-- ^ The exact dependencies (on other plan packages)
-- The boolean value indicates whether the dependency is a promised dependency
@@ -725,9 +803,9 @@ data ElaboratedPackage = ElaboratedPackage
-- defined library. These are used by 'elabRequiresRegistration',
-- to determine if a user-requested build is going to need
-- a library registration
- , pkgExeDependencies :: ComponentDeps [ConfiguredId]
+ , pkgExeDependencies :: ComponentDeps [WithStage ConfiguredId]
-- ^ Dependencies on executable packages.
- , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)]
+ , pkgExeDependencyPaths :: ComponentDeps [(WithStage ConfiguredId, FilePath)]
-- ^ Paths where executable dependencies live.
, pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)]
-- ^ Dependencies on @pkg-config@ packages.
@@ -786,13 +864,6 @@ whyNotPerComponent = \case
CuzNoBuildableComponents -> "there are no buildable components"
CuzDisablePerComponent -> "you passed --disable-per-component"
--- | See 'elabOrderDependencies'. This gives the unflattened version,
--- which can be useful in some circumstances.
-pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId]
-pkgOrderDependencies pkg =
- fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg)
- `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg)
-
-- | This is used in the install plan to indicate how the package will be
-- built.
data BuildStyle
diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs
index faeb91b3a88..2ba8b65aca2 100644
--- a/cabal-install/src/Distribution/Client/RebuildMonad.hs
+++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -76,6 +75,7 @@ import Control.Monad
import Control.Monad.Reader as Reader
import Control.Monad.State as State
import qualified Data.Map.Strict as Map
+import System.Environment (getExecutablePath)
import System.Directory
import System.FilePath
@@ -134,6 +134,13 @@ rerunIfChanged verbosity monitor key action = do
[x] -> return x
_ -> error "rerunIfChanged: impossible!"
+-- | Monitor our current executable file for changes. This is useful to prevent
+-- stale cache when upgrading the cabal executable itself or while developing.
+monitorOurselves :: Rebuild ()
+monitorOurselves = do
+ self <- liftIO getExecutablePath
+ monitorFiles [monitorFile self]
+
-- | Like 'rerunIfChanged' meets 'mapConcurrently': For when we want multiple actions
-- that need to do be re-run-if-changed asynchronously. The function returns
-- when all values have finished computing.
@@ -144,6 +151,8 @@ rerunConcurrentlyIfChanged
-> [(FileMonitor a b, a, Rebuild b)]
-> Rebuild [b]
rerunConcurrentlyIfChanged verbosity mkJobControl triples = do
+ -- Implicitly add a monitor on our own executable file
+ monitorOurselves
rootDir <- askRoot
dacts <- forM triples $ \(monitor, key, action) -> do
let monitorName = takeFileName (fileMonitorCacheFile monitor)
diff --git a/cabal-install/src/Distribution/Client/Run.hs b/cabal-install/src/Distribution/Client/Run.hs
index baa6264abe4..dcc9d7fba78 100644
--- a/cabal-install/src/Distribution/Client/Run.hs
+++ b/cabal-install/src/Distribution/Client/Run.hs
@@ -1,8 +1,3 @@
------------------------------------------------------------------------------
-{-# LANGUAGE DataKinds #-}
-
------------------------------------------------------------------------------
-
-- |
-- Module : Distribution.Client.Run
-- Maintainer : cabal-devel@haskell.org
diff --git a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs
index 02cb770a031..d13a8107a75 100644
--- a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs
+++ b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs
index 9c34117a753..68d4b48e48d 100644
--- a/cabal-install/src/Distribution/Client/ScriptUtils.hs
+++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs
@@ -71,7 +71,7 @@ import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
( ElaboratedConfiguredPackage (..)
, ElaboratedSharedConfig (..)
- , configureCompiler
+ , configureToolchains
)
import Distribution.Client.RebuildMonad
( runRebuild
@@ -83,6 +83,9 @@ import Distribution.Client.TargetSelector
( TargetSelectorProblem (..)
, TargetString (..)
)
+import Distribution.Client.Toolchain
+ ( Toolchain (..)
+ )
import Distribution.Client.Types
( PackageLocation (..)
, PackageSpecifier (..)
@@ -191,6 +194,7 @@ import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ()
import qualified Data.Set as S
import Distribution.Client.Errors
+import Distribution.Solver.Types.Stage (Stage (..), getStage)
import Distribution.Utils.Path
( unsafeMakeSymbolicPath
)
@@ -359,9 +363,9 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS
exists <- doesFileExist script
if exists
then do
- ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)
+ baseCtx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)
- let projectRoot = distProjectRootDirectory $ distDirLayout ctx
+ let projectRoot = distProjectRootDirectory $ distDirLayout baseCtx
writeFile (projectRoot "scriptlocation") =<< canonicalizePath script
scriptContents <- BS.readFile script
@@ -373,16 +377,20 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS
(fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
(flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
- projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents
+ projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout baseCtx) (takeFileName script) scriptContents
+
+ createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout baseCtx)
+
+ toolchains <-
+ runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (snd (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx)
- createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
- (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
+ let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host
- (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton
+ (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton
- let ctx' = ctx & lProjectConfig %~ (<> projectCfg)
+ let ctx' = baseCtx & lProjectConfig %~ (<> projectCfg)
- build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform
+ build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform
exePath = build_dir "bin" scriptExeFileName script
exePathRel = makeRelative (normalise projectRoot) exePath
@@ -425,7 +433,8 @@ scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath
scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams
scriptDistDirParams scriptPath ctx compiler platform =
DistDirParams
- { distParamUnitId = newSimpleUnitId cid
+ { distParamStage = Host
+ , distParamUnitId = newSimpleUnitId cid
, distParamPackageId = fakePackageId
, distParamComponentId = cid
, distParamComponentName = Just $ CExeName cn
@@ -468,14 +477,13 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do
let projectRoot = distProjectRootDirectory $ distDirLayout ctx
absScript <- unsafeMakeSymbolicPath . makeRelative (normalise projectRoot) <$> canonicalizePath scriptPath
- let
- sourcePackage =
- fakeProjectSourcePackage projectRoot
- & lSrcpkgDescription . L.condExecutables
- .~ [(scriptComponentName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])]
- executable =
- scriptExecutable
- & L.modulePath .~ absScript
+ let sourcePackage =
+ fakeProjectSourcePackage projectRoot
+ & lSrcpkgDescription . L.condExecutables
+ .~ [(scriptComponentName scriptPath, CondNode executable [])]
+ executable =
+ scriptExecutable
+ & L.modulePath .~ absScript
updateContextAndWriteProjectFile' ctx sourcePackage
@@ -586,10 +594,12 @@ fakeProjectSourcePackage projectRoot = sourcePackage
movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath
movedExePath selectedComponent distDirLayout elabShared elabConfigured = do
exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured
- let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared
+ let CompilerId flavor _ = compilerId toolchainCompiler
opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe)
let projectRoot = distProjectRootDirectory distDirLayout
fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts))
+ where
+ Toolchain{..} = getStage (pkgConfigToolchains elabShared) (elabStage elabConfigured)
-- Lenses
diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs
index c2651a33331..f1349844489 100644
--- a/cabal-install/src/Distribution/Client/Setup.hs
+++ b/cabal-install/src/Distribution/Client/Setup.hs
@@ -164,7 +164,7 @@ import Distribution.ReadE
)
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
-import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack)
+import Distribution.Simple.Compiler (Compiler, CompilerFlavor (..), PackageDB, PackageDBStack)
import Distribution.Simple.Configure
( computeEffectiveProfiling
, configCompilerAuxEx
@@ -915,6 +915,10 @@ data ConfigExFlags = ConfigExFlags
, configAllowOlder :: Maybe AllowOlder
, configWriteGhcEnvironmentFilesPolicy
:: Flag WriteGhcEnvironmentFilesPolicy
+ , configBuildHcFlavor :: Flag CompilerFlavor
+ , configBuildHcPath :: Flag FilePath
+ , configBuildHcPkg :: Flag FilePath
+ , configBuildPackageDBs :: [Maybe PackageDB]
}
deriving (Eq, Show, Generic)
@@ -1042,6 +1046,20 @@ configureExOptions _showOrParseArgs src =
writeGhcEnvironmentFilesPolicyParser
writeGhcEnvironmentFilesPolicyPrinter
)
+ , option
+ "W"
+ ["with-build-compiler", "with-build-hc"]
+ "give the path to the compiler for the build stage"
+ configBuildHcPath
+ (\v flags -> flags{configBuildHcPath = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["with-build-hc-pkg"]
+ "give the path to the package tool for the build stage"
+ configBuildHcPkg
+ (\v flags -> flags{configBuildHcPkg = v})
+ (reqArgFlag "PATH")
]
writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy)
diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs
index acb8f031c3a..bf2748b4ff3 100644
--- a/cabal-install/src/Distribution/Client/SetupWrapper.hs
+++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
{- FOURMOLU_DISABLE -}
-----------------------------------------------------------------------------
@@ -23,12 +25,16 @@
-- setup actions directly. Otherwise it builds the setup script and
-- runs it with the given arguments.
module Distribution.Client.SetupWrapper
- ( getSetup
- , runSetup
- , runSetupCommand
+ ( SetupRunnerArgs(..)
+ , SPostConfigurePhase(..)
+ , InLibraryArgs(..)
+ , SetupRunnerRes
+ , InLibraryLBI(..)
+ , RightFlagsForPhase
, setupWrapper
, SetupScriptOptions (..)
, defaultSetupScriptOptions
+ , externalSetupMethod
) where
import Distribution.Client.Compat.Prelude
@@ -36,7 +42,6 @@ import Prelude ()
import qualified Distribution.Backpack as Backpack
import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)
-import qualified Distribution.Make as Make
import Distribution.Package
( ComponentId
, PackageId
@@ -54,18 +59,17 @@ import Distribution.PackageDescription
, buildType
, specVersion
)
+import qualified Distribution.Make as Make
import qualified Distribution.Simple as Simple
import Distribution.Simple.Build.Macros
( generatePackageVersionMacros
)
import Distribution.Simple.BuildPaths
- ( defaultDistPref
- , exeExtension
+ ( exeExtension
)
import Distribution.Simple.Compiler
import Distribution.Simple.Configure
- ( configCompilerEx
- )
+ hiding ( getInstalledPackages )
import Distribution.Simple.PackageDescription
( readGenericPackageDescription
)
@@ -74,19 +78,7 @@ import Distribution.Simple.PreProcess
, runSimplePreProcessor
)
import Distribution.Simple.Program
- ( ProgramDb
- , emptyProgramDb
- , getDbProgramOutputCwd
- , getProgramSearchPath
- , ghcProgram
- , ghcjsProgram
- , runDbProgramCwd
- )
import Distribution.Simple.Program.Db
- ( configureAllKnownPrograms
- , prependProgramSearchPath
- , progOverrideEnv
- )
import Distribution.Simple.Program.Find
( programSearchPathAsPATHVar
)
@@ -109,6 +101,8 @@ import Distribution.Version
import Distribution.Client.Config
( defaultCacheDir
)
+import Distribution.Client.FileMonitor
+ ( MonitorFilePath )
import Distribution.Client.IndexUtils
( getInstalledPackages
)
@@ -144,12 +138,6 @@ import Distribution.Simple.Program.GHC
, GhcOptions (..)
, renderGhcOptions
)
-import Distribution.Simple.Setup
- ( CommonSetupFlags (..)
- , pattern Flag
- , GlobalFlags (..)
- , globalCommand
- )
import Distribution.Simple.Utils
( cabalVersion
, copyFileVerbose
@@ -172,55 +160,130 @@ import Distribution.Utils.Generic
import Distribution.Compat.Stack
import Distribution.ReadE
+import Distribution.Simple.Setup
+import Distribution.Compat.Process (proc)
import Distribution.System (Platform (..), buildPlatform)
import Distribution.Utils.NubList
( toNubListR
)
+import Distribution.Types.LocalBuildInfo ( LocalBuildInfo )
+import qualified Distribution.Types.LocalBuildInfo as LBI
import Distribution.Verbosity
-
+import Distribution.Client.Errors
+import qualified Distribution.Client.InLibrary as InLibrary
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Simple.SetupHooks.HooksMain
+ ( hooksVersion )
+import Distribution.Client.SetupHooks.CallHooksExe
+ ( externalSetupHooksABI, hooksProgFilePath )
import Data.List (foldl1')
+import Data.Kind (Type, Constraint)
import qualified Data.Map.Lazy as Map
-import System.Environment (getExecutablePath)
-import Distribution.Compat.Process (proc)
+import Data.Type.Equality ( type (==) )
+import Data.Type.Bool ( If )
import System.Directory (doesFileExist)
+import System.Environment (getExecutablePath)
import System.FilePath ((<.>), ())
import System.IO (Handle, hPutStr)
import System.Process (StdStream (..))
import qualified System.Process as Process
import qualified Data.ByteString.Lazy as BS
-import Distribution.Client.Errors
#ifdef mingw32_HOST_OS
import Distribution.Simple.Utils
( withTempDirectory )
import Control.Exception ( bracket )
-import System.FilePath ( equalFilePath, takeDirectory )
import System.Directory ( doesDirectoryExist )
+import System.FilePath ( equalFilePath, takeDirectory, takeFileName )
import qualified System.Win32 as Win32
#endif
+data AllowInLibrary
+ = AllowInLibrary
+ | Don'tAllowInLibrary
+ deriving Eq
+
+data SetupKind
+ = InLibrary
+ | GeneralSetup
+
+-- | If we end up using the in-library method, we use the v'InLibraryLBI'
+-- constructor. If not, we use the 'NotInLibraryNoLBI' constructor.
+--
+-- NB: we don't know ahead of time whether we can use the in-library method;
+-- e.g. for a package with Hooks build-type, it depends on whether the Cabal
+-- version used by the package matches with the Cabal version that cabal-install
+-- was built against.
+data InLibraryLBI
+ = InLibraryLBI LocalBuildInfo
+ | NotInLibraryNoLBI
+
+data SPostConfigurePhase (flags :: Type) where
+ SBuildPhase :: SPostConfigurePhase BuildFlags
+ SHaddockPhase :: SPostConfigurePhase HaddockFlags
+ SReplPhase :: SPostConfigurePhase ReplFlags
+ SCopyPhase :: SPostConfigurePhase CopyFlags
+ SRegisterPhase :: SPostConfigurePhase RegisterFlags
+ STestPhase :: SPostConfigurePhase TestFlags
+ SBenchPhase :: SPostConfigurePhase BenchmarkFlags
+
+data SetupWrapperSpec
+ = TryInLibrary Type
+ | UseGeneralSetup
+
+type family RightFlagsForPhase (flags :: Type) (setupSpec :: SetupWrapperSpec) :: Constraint where
+ RightFlagsForPhase flags UseGeneralSetup = ()
+ RightFlagsForPhase flags (TryInLibrary flags') = flags ~ flags'
+
+data SetupRunnerArgs (spec :: SetupWrapperSpec) where
+ NotInLibrary
+ :: SetupRunnerArgs UseGeneralSetup
+ InLibraryArgs
+ :: InLibraryArgs flags
+ -> SetupRunnerArgs (TryInLibrary flags)
+
+data InLibraryArgs (flags :: Type) where
+ InLibraryConfigureArgs
+ :: ElaboratedSharedConfig
+ -> ElaboratedReadyPackage
+ -> InLibraryArgs ConfigFlags
+ InLibraryPostConfigureArgs
+ :: SPostConfigurePhase flags
+ -> InLibraryLBI
+ -> InLibraryArgs flags
+
+type family SetupRunnerRes (spec :: SetupWrapperSpec) where
+ SetupRunnerRes UseGeneralSetup = ()
+ SetupRunnerRes (TryInLibrary phase) = InLibraryPhaseRes phase
+
+type family InLibraryPhaseRes flags where
+ InLibraryPhaseRes ConfigFlags = InLibraryLBI
+ InLibraryPhaseRes BuildFlags = [MonitorFilePath]
+ InLibraryPhaseRes HaddockFlags = [MonitorFilePath]
+ InLibraryPhaseRes ReplFlags = [MonitorFilePath]
+ InLibraryPhaseRes _ = ()
+
-- | @Setup@ encapsulates the outcome of configuring a setup method to build a
-- particular package.
-data Setup = Setup
- { setupMethod :: SetupMethod
+data Setup kind = Setup
+ { setupMethod :: SetupMethod kind
, setupScriptOptions :: SetupScriptOptions
, setupVersion :: Version
, setupBuildType :: BuildType
, setupPackage :: PackageDescription
}
+data ASetup = forall kind. ASetup ( Setup kind )
+
-- | @SetupMethod@ represents one of the methods used to run Cabal commands.
-data SetupMethod
- = -- | run Cabal commands through \"cabal\" in the
- -- current process
- InternalMethod
- | -- | run Cabal commands through \"cabal\" as a
- -- child process
- SelfExecMethod
- | -- | run Cabal commands through a custom \"Setup\" executable
- ExternalMethod FilePath
+data SetupMethod (kind :: SetupKind) where
+ -- | Directly use Cabal library functions, bypassing the Setup
+ -- mechanism entirely.
+ LibraryMethod :: SetupMethod InLibrary
+ -- | run Cabal commands through a custom \"Setup\" executable
+ ExternalMethod :: FilePath -> SetupMethod GeneralSetup
-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two
-- parts: one that has no policy and just does as it's told with all the
@@ -249,7 +312,7 @@ data SetupScriptOptions = SetupScriptOptions
--
-- This is similar to 'useCabalVersion' but instead of probing the system
-- for a version of the /Cabal library/ you just say exactly which version
- -- of the /spec/ we will use. Using this also avoid adding the Cabal
+ -- of the /spec/ we will use. Using this also avoids adding the Cabal
-- library as an additional dependency, so add it to 'useDependencies'
-- if needed.
, useCompiler :: Maybe Compiler
@@ -267,7 +330,6 @@ data SetupScriptOptions = SetupScriptOptions
--
-- * @'Just' v@ means \"set the environment variable's value to @v@\".
-- * 'Nothing' means \"unset the environment variable\".
- , forceExternalSetupMethod :: Bool
, useDependencies :: [(ComponentId, PackageId)]
-- ^ List of dependencies to use when building Setup.hs.
, useDependenciesExclusive :: Bool
@@ -343,7 +405,6 @@ defaultSetupScriptOptions =
, useExtraPathEnv = []
, useExtraEnvOverrides = []
, useWin32CleanHack = False
- , forceExternalSetupMethod = False
, setupCacheLock = Nothing
, isInteractive = False
, isMainLibOrExeComponent = True
@@ -358,12 +419,13 @@ workingDir options = case useWorkingDir options of
_ -> "."
-- | A @SetupRunner@ implements a 'SetupMethod'.
-type SetupRunner =
+type SetupRunner kind =
Verbosity
-> SetupScriptOptions
-> BuildType
-> [String]
- -> IO ()
+ -> SetupRunnerArgs kind
+ -> IO (SetupRunnerRes kind)
-- | Prepare to build a package by configuring a 'SetupMethod'. The returned
-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed
@@ -373,8 +435,9 @@ getSetup
:: Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
- -> IO Setup
-getSetup verbosity options mpkg = do
+ -> AllowInLibrary
+ -> IO ASetup
+getSetup verbosity options mpkg allowInLibrary = do
pkg <- maybe getPkg return mpkg
let options' =
options
@@ -391,57 +454,81 @@ getSetup verbosity options mpkg = do
buildType' = case (buildType pkg, isMainLibOrExeComponent options) of
(Configure, False) -> Simple
(bt, _) -> bt
- (version, method, options'') <-
- getSetupMethod verbosity options' pkg buildType'
- return
- Setup
- { setupMethod = method
- , setupScriptOptions = options''
- , setupVersion = version
- , setupBuildType = buildType'
- , setupPackage = pkg
- }
+ withSetupMethod verbosity options' pkg buildType' allowInLibrary $
+ \ (version, method, options'') ->
+ ASetup $ Setup
+ { setupMethod = method
+ , setupScriptOptions = options''
+ , setupVersion = version
+ , setupBuildType = buildType'
+ , setupPackage = pkg
+ }
where
mbWorkDir = useWorkingDir options
getPkg =
- (relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir)
- >>= readGenericPackageDescription verbosity mbWorkDir
+ (tryFindPackageDesc verbosity mbWorkDir >>= readGenericPackageDescription verbosity mbWorkDir . relativeSymbolicPath)
>>= return . packageDescription
-- | Decide if we're going to be able to do a direct internal call to the
-- entry point in the Cabal library or if we're going to have to compile
-- and execute an external Setup.hs script.
-getSetupMethod
+withSetupMethod
:: Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
- -> IO (Version, SetupMethod, SetupScriptOptions)
-getSetupMethod verbosity options pkg buildType'
+ -> AllowInLibrary
+ -> ( forall kind. (Version, SetupMethod kind, SetupScriptOptions ) -> r )
+ -> IO r
+withSetupMethod verbosity options pkg buildType' allowInLibrary with
| buildType' == Custom
- || buildType' == Hooks
|| maybe False (cabalVersion /=) (useCabalSpecVersion options)
- || not (cabalVersion `withinRange` useCabalVersion options) =
- getExternalSetupMethod verbosity options pkg buildType'
- | -- Forcing is done to use an external process e.g. due to parallel
- -- build concerns.
- forceExternalSetupMethod options =
- return (cabalVersion, SelfExecMethod, options)
- | otherwise = return (cabalVersion, InternalMethod, options)
-
-runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)
-runSetupMethod InternalMethod = internalSetupMethod
+ || not (cabalVersion `withinRange` useCabalVersion options)
+ || allowInLibrary == Don'tAllowInLibrary
+ || (buildType' == Hooks && not hasHooksMain) =
+ withExternalSetupMethod
+ | buildType' == Hooks = do
+ -- NB: needs 'hooksMain' available in Cabal to compile the external
+ -- hooks executable, hence the 'not hasHooksMain' guard above.
+ compileExternalExe verbosity options pkg buildType' WantHooks
+ externalHooksABI <-
+ externalSetupHooksABI verbosity $
+ hooksProgFilePath (useWorkingDir options) (useDistPref options)
+ let internalHooksABI = hooksVersion
+ if externalHooksABI == internalHooksABI
+ then do
+ debug verbosity "Using in-library setup method with build-type Hooks."
+ return $ with (cabalVersion, LibraryMethod, options)
+ else do
+ debug verbosity "Hooks ABI mismatch; falling back to external setup method."
+ withExternalSetupMethod
+ | otherwise = do
+ debug verbosity $ "Using in-library setup method with build-type " ++ show buildType'
+ return $ with (cabalVersion, LibraryMethod, options)
+ where
+ hasHooksMain =
+ case cabalLibFromOptions options of
+ Just (v, _) -> v >= mkVersion [3, 17]
+ Nothing -> False
+ withExternalSetupMethod = do
+ debug verbosity $ "Using external setup method with build-type " ++ show buildType'
+ debug verbosity $
+ "Using explicit dependencies: "
+ ++ show (useDependenciesExclusive options)
+ with <$> compileExternalExe verbosity options pkg buildType' WantSetup
+
+runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup)
runSetupMethod (ExternalMethod path) = externalSetupMethod path
-runSetupMethod SelfExecMethod = selfExecSetupMethod
-- | Run a configured 'Setup' with specific arguments.
runSetup
:: Verbosity
- -> Setup
+ -> Setup GeneralSetup
-> [String]
-- ^ command-line arguments
- -> IO ()
-runSetup verbosity setup args0 = do
+ -> SetupRunnerArgs UseGeneralSetup
+ -> IO (SetupRunnerRes UseGeneralSetup)
+runSetup verbosity setup args0 setupArgs = do
let method = setupMethod setup
options = setupScriptOptions setup
bt = setupBuildType setup
@@ -455,7 +542,7 @@ runSetup verbosity setup args0 = do
++ " After: "
++ show args
++ "\n"
- runSetupMethod method verbosity options bt args
+ runSetupMethod method verbosity options bt args setupArgs
-- | This is a horrible hack to make sure passing fancy verbosity
-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on
@@ -494,7 +581,7 @@ verbosityHack ver args0
-- | Run a command through a configured 'Setup'.
runSetupCommand
:: Verbosity
- -> Setup
+ -> Setup GeneralSetup
-> CommandUI flags
-- ^ command definition
-> (flags -> CommonSetupFlags)
@@ -502,20 +589,23 @@ runSetupCommand
-- ^ command flags
-> [String]
-- ^ extra command-line arguments
- -> IO ()
-runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs =
+ -> SetupRunnerArgs UseGeneralSetup
+ -> IO (SetupRunnerRes UseGeneralSetup)
+runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs setupArgs =
-- The 'setupWorkingDir' flag corresponds to a global argument which needs to
-- be passed before the individual command (e.g. 'configure' or 'build').
let common = getCommonFlags flags
globalFlags = mempty { globalWorkingDir = setupWorkingDir common }
args = commandShowOptions (globalCommand []) globalFlags
++ (commandName cmd : commandShowOptions cmd flags ++ extraArgs)
- in runSetup verbosity setup args
+ in runSetup verbosity setup args setupArgs
-- | Configure a 'Setup' and run a command in one step. The command flags
-- may depend on the Cabal library version in use.
setupWrapper
- :: Verbosity
+ :: forall setupSpec flags
+ . RightFlagsForPhase flags setupSpec
+ => Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
@@ -523,34 +613,144 @@ setupWrapper
-> (Version -> IO flags)
-- ^ produce command flags given the Cabal library version
-> (Version -> [String])
- -> IO ()
-setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs = do
- setup <- getSetup verbosity options mpkg
+ -> SetupRunnerArgs setupSpec
+ -> IO (SetupRunnerRes setupSpec)
+setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs wrapperArgs = do
+ let allowInLibrary = case wrapperArgs of
+ NotInLibrary -> Don'tAllowInLibrary
+ InLibraryArgs {} -> AllowInLibrary
+ ASetup (setup :: Setup kind) <- getSetup verbosity options mpkg allowInLibrary
let version = setupVersion setup
- extraArgs = getExtraArgs version
flags <- getFlags version
- runSetupCommand
- verbosity
- setup
- cmd
- getCommonFlags
- flags
- extraArgs
+ let
+ verbHandles = verbosityHandles verbosity
+ extraArgs = getExtraArgs version
+ notInLibraryMethod :: kind ~ GeneralSetup => IO (SetupRunnerRes setupSpec)
+ notInLibraryMethod = do
+ runSetupCommand verbosity setup cmd getCommonFlags flags extraArgs NotInLibrary
+ return $ case wrapperArgs of
+ NotInLibrary -> ()
+ InLibraryArgs libArgs ->
+ case libArgs of
+ InLibraryConfigureArgs {} -> NotInLibraryNoLBI
+ InLibraryPostConfigureArgs sPhase _ ->
+ case sPhase of
+ SBuildPhase -> []
+ SHaddockPhase -> []
+ SReplPhase -> []
+ SCopyPhase -> ()
+ SRegisterPhase -> ()
+ STestPhase -> ()
+ SBenchPhase -> ()
+ case setupMethod setup of
+ LibraryMethod ->
+ case wrapperArgs of
+ InLibraryArgs libArgs ->
+ case libArgs of
+ InLibraryConfigureArgs elabSharedConfig elabReadyPkg -> do
+ -- See (1)(a) in Note [Constructing the ProgramDb]
+ baseProgDb <-
+ prependProgramSearchPath verbosity
+ (useExtraPathEnv options)
+ (useExtraEnvOverrides options) =<<
+ mkProgramDb verbHandles flags -- Passes user-supplied arguments to e.g. GHC
+ (restoreProgramDb builtinPrograms $
+ useProgramDb options) -- Recall that 'useProgramDb' is set to 'pkgConfigCompilerProgs'
+ -- See (2) in Note [Constructing the ProgramDb]
+ setupProgDb <-
+ configCompilerProgDb
+ verbosity
+ (toolchainCompiler $ getStage (pkgConfigToolchains elabSharedConfig) Host)
+ baseProgDb
+ Nothing -- we use configProgramPaths instead
+ lbi0 <-
+ InLibrary.configure
+ (InLibrary.libraryConfigureInputsFromElabPackage
+ verbHandles
+ (setupBuildType setup)
+ setupProgDb
+ elabSharedConfig
+ elabReadyPkg
+ extraArgs
+ )
+ flags
+ let progs0 = LBI.withPrograms lbi0
+ -- See (1)(b) in Note [Constructing the ProgramDb]
+ progs1 <- updatePathProgDb verbosity progs0
+ let
+ lbi =
+ lbi0
+ { LBI.withPrograms = progs1
+ }
+ mbWorkDir = useWorkingDir options
+ distPref = useDistPref options
+ -- Write the LocalBuildInfo to disk. This is needed, for instance, if we
+ -- skip re-configuring; we retrieve the LocalBuildInfo stored on disk from
+ -- the previous invocation of 'configure' and pass it to 'build'.
+ writePersistBuildConfig mbWorkDir distPref lbi
+ return (InLibraryLBI lbi)
+ InLibraryPostConfigureArgs sPhase mbLBI ->
+ case mbLBI of
+ NotInLibraryNoLBI ->
+ error "internal error: in-library post-conf but no LBI"
+ -- To avoid running into the above error, we must ensure that
+ -- when we skip re-configuring, we retrieve the cached
+ -- LocalBuildInfo (see "whenReconfigure"
+ -- in Distribution.Client.ProjectBuilding.UnpackedPackage).
+ InLibraryLBI lbi ->
+ case sPhase of
+ SBuildPhase -> InLibrary.build verbHandles flags lbi extraArgs
+ SHaddockPhase -> InLibrary.haddock verbHandles flags lbi extraArgs
+ SReplPhase -> InLibrary.repl verbHandles flags lbi extraArgs
+ SCopyPhase -> InLibrary.copy verbHandles flags lbi extraArgs
+ STestPhase -> InLibrary.test verbHandles flags lbi extraArgs
+ SBenchPhase -> InLibrary.bench verbHandles flags lbi extraArgs
+ SRegisterPhase -> InLibrary.register flags lbi extraArgs
+ NotInLibrary ->
+ error "internal error: NotInLibrary argument but getSetup chose InLibrary"
+ ExternalMethod {} -> notInLibraryMethod
+
+{- Note [Constructing the ProgramDb]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When using the in-library method for configuring a package, we want to start off
+with the information cabal-install already has in hand, such as the compiler.
+Specifically, we skip 'Cabal.Distribution.Simple.preConfigurePackage', which
+includes the call to 'configCompilerEx'.
+
+To obtain a program database with all the required information, we do a few
+things:
+
+ (1)
+ (a) When building a package with internal build tools, we must ensure that
+ these build tools are available in PATH, with appropriate environment
+ variable overrides for their data directory. To do this, we call
+ 'prependProgramSearchPath'.
+
+ (b) Moreover, these programs must be available in the search paths for the
+ compiler itself, in case they are run at compile-time (e.g. with a Template
+ Haskell splice). We achieve this using 'updatePathProgDb'.
+
+ (2) Given the compiler, we must compute the ProgramDb of programs that are
+ specified alongside the compiler, such as ghc-pkg, haddock, and toolchain
+ programs such as ar, ld.
+
+ We do this using the function 'configCompilerProgDb'.
+-}
-- ------------------------------------------------------------
--- * Internal SetupMethod
+-- * 'invoke' function
-- ------------------------------------------------------------
-- | Run a Setup script by directly invoking the @Cabal@ library.
-internalSetupMethod :: SetupRunner
-internalSetupMethod verbosity options bt args = do
+internalSetupMethod :: SetupRunner UseGeneralSetup
+internalSetupMethod verbosity options bt args NotInLibrary = do
info verbosity $
"Using internal setup method with build-type "
++ show bt
++ " and args:\n "
- ++ show args
+ ++ unwords args
-- NB: we do not set the working directory of the process here, because
-- we will instead pass the -working-dir flag when invoking the Setup script.
-- Note that the Setup script is guaranteed to support this flag, because
@@ -562,20 +762,17 @@ internalSetupMethod verbosity options bt args = do
withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $
withExtraPathEnv (useExtraPathEnv options) $
withEnvOverrides (useExtraEnvOverrides options) $
- buildTypeAction (verbosityHandles verbosity) bt args
-
-buildTypeAction :: VerbosityHandles -> BuildType -> ([String] -> IO ())
-buildTypeAction verbHandles = \ case
- Simple ->
- Simple.defaultMainArgsWithHandles verbHandles
- Configure ->
- Simple.defaultMainWithSetupHooksArgs Simple.autoconfSetupHooks verbHandles
- Make ->
- Make.defaultMainArgsWithHandles verbHandles
- Hooks ->
- error "buildTypeAction Hooks"
- Custom ->
- error "buildTypeAction Custom"
+ buildTypeAction bt args
+
+buildTypeAction :: BuildType -> ([String] -> IO ())
+buildTypeAction Simple = Simple.defaultMainArgs
+buildTypeAction Configure =
+ Simple.defaultMainWithSetupHooksArgs
+ Simple.autoconfSetupHooks
+ defaultVerbosityHandles
+buildTypeAction Make = Make.defaultMainArgs
+buildTypeAction Hooks = error "buildTypeAction Hooks"
+buildTypeAction Custom = error "buildTypeAction Custom"
invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO ()
invoke verbosity path args options = do
@@ -613,8 +810,8 @@ invoke verbosity path args options = do
-- ------------------------------------------------------------
-selfExecSetupMethod :: SetupRunner
-selfExecSetupMethod verbosity options bt args0 = do
+selfExecSetupMethod :: SetupRunner UseGeneralSetup
+selfExecSetupMethod verbosity options bt args0 NotInLibrary = do
let args =
[ "act-as-setup"
, "--build-type=" ++ prettyShow bt
@@ -625,7 +822,7 @@ selfExecSetupMethod verbosity options bt args0 = do
"Using self-exec internal setup method with build-type "
++ show bt
++ " and args:\n "
- ++ show args
+ ++ unwords args
path <- getExecutablePath
invoke verbosity path args options
@@ -635,8 +832,8 @@ selfExecSetupMethod verbosity options bt args0 = do
-- ------------------------------------------------------------
-externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)
-externalSetupMethod path verbosity options _ args =
+externalSetupMethod :: WithCallStack (FilePath -> SetupRunner UseGeneralSetup)
+externalSetupMethod path verbosity options _ args NotInLibrary =
#ifndef mingw32_HOST_OS
invoke
verbosity
@@ -661,7 +858,7 @@ externalSetupMethod path verbosity options _ args =
(\tmpPath -> invoke' tmpPath)
moveOutOfTheWay tmpDir origPath = do
- let tmpPath = tmpDir "setup" <.> exeExtension buildPlatform
+ let tmpPath = tmpDir takeFileName origPath
Win32.moveFile origPath tmpPath
return tmpPath
@@ -674,29 +871,45 @@ externalSetupMethod path verbosity options _ args =
#endif
-getExternalSetupMethod
+useCachedSetupExecutable :: BuildType -> Bool
+useCachedSetupExecutable bt =
+ bt == Simple || bt == Configure || bt == Make
+
+data ExternalExe = HooksExe | SetupExe
+data WantedExternalExe (meth :: ExternalExe) where
+ WantHooks :: WantedExternalExe HooksExe
+ WantSetup :: WantedExternalExe SetupExe
+
+compileExternalExe
:: Verbosity
-> SetupScriptOptions
-> PackageDescription
-> BuildType
- -> IO (Version, SetupMethod, SetupScriptOptions)
-getExternalSetupMethod verbosity options pkg bt = do
- debug verbosity $ "Using external setup method with build-type " ++ show bt
- debug verbosity $
- "Using explicit dependencies: "
- ++ show (useDependenciesExclusive options)
- createDirectoryIfMissingVerbose verbosity True $ i setupDir
- (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse
+ -> WantedExternalExe exe
+ -> IO (If (exe == HooksExe) () (Version, SetupMethod GeneralSetup, SetupScriptOptions))
+compileExternalExe verbosity options pkg bt wantedExe = do
+ createDirectoryIfMissingVerbose verbosity True $ i (setupDir options)
+ (cabalLibVersion, mCabalLibInstalledPkgId, options') <-
+ cabalLibVersionToUse verbosity options (package pkg) bt wantedExe
debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion
- path <-
- if useCachedSetupExecutable
+ exePath <-
+ if useCachedSetupExecutable bt
then
getCachedSetupExecutable
+ verbosity
+ platform
+ (package pkg)
+ bt
options'
cabalLibVersion
mCabalLibInstalledPkgId
else
- compileSetupExecutable
+ compileExe
+ verbosity
+ platform
+ (package pkg)
+ bt
+ wantedExe
options'
cabalLibVersion
mCabalLibInstalledPkgId
@@ -706,466 +919,592 @@ getExternalSetupMethod verbosity options pkg bt = do
-- be turned into an absolute path. On some systems, runProcess' will take
-- path as relative to the new working directory instead of the current
-- working directory.
- path' <- tryCanonicalizePath path
+ exePath' <- tryCanonicalizePath exePath
-- See 'Note: win32 clean hack' above.
#ifdef mingw32_HOST_OS
-- setupProgFile may not exist if we're using a cached program
- setupProgFile' <- canonicalizePathNoThrow $ i setupProgFile
+ setupProgFile' <- canonicalizePathNoThrow $ i (setupProgFile options)
let win32CleanHackNeeded =
(useWin32CleanHack options)
-- Skip when a cached setup script is used.
- && setupProgFile' `equalFilePath` path'
+ && setupProgFile' `equalFilePath` exePath'
#else
let win32CleanHackNeeded = False
#endif
let options'' = options'{useWin32CleanHack = win32CleanHackNeeded}
- return (cabalLibVersion, ExternalMethod path', options'')
+ case wantedExe of
+ WantHooks -> return ()
+ WantSetup -> return (cabalLibVersion, ExternalMethod exePath', options'')
where
mbWorkDir = useWorkingDir options
-- See Note [Symbolic paths] in Distribution.Utils.Path
+ i :: SymbolicPathX allowAbs Pkg to -> FilePath
i = interpretSymbolicPath mbWorkDir
- setupDir = useDistPref options Cabal.Path. makeRelativePathEx "setup"
- setupVersionFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "version")
- setupHs = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> "hs")
- setupHooks = setupDir Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs")
- setupProgFile = setupDir Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform)
-
platform = fromMaybe buildPlatform (usePlatform options)
- useCachedSetupExecutable =
- bt == Simple || bt == Configure || bt == Make
-
- maybeGetInstalledPackages
- :: SetupScriptOptions
- -> Compiler
- -> ProgramDb
- -> IO InstalledPackageIndex
- maybeGetInstalledPackages options' comp progdb =
- case usePackageIndex options' of
- Just index -> return index
- Nothing ->
- getInstalledPackages
- verbosity
- comp
- (usePackageDB options')
- progdb
-
- -- Choose the version of Cabal to use if the setup script has a dependency on
- -- Cabal, and possibly update the setup script options. The version also
- -- determines how to filter the flags to Setup.
- --
- -- We first check whether the dependency solver has specified a Cabal version.
- -- If it has, we use the solver's version without looking at the installed
- -- package index (See issue #3436). Otherwise, we pick the Cabal version by
- -- checking 'useCabalSpecVersion', then the saved version, and finally the
- -- versions available in the index.
- --
- -- The version chosen here must match the one used in 'compileSetupExecutable'
- -- (See issue #3433).
- cabalLibVersionToUse
- :: IO
- ( Version
- , Maybe ComponentId
- , SetupScriptOptions
- )
- cabalLibVersionToUse =
- case find (isCabalPkgId . snd) (useDependencies options) of
- Just (unitId, pkgId) -> do
- let version = pkgVersion pkgId
- updateSetupScript version bt
- writeSetupVersionFile version
- return (version, Just unitId, options)
- Nothing ->
- case useCabalSpecVersion options of
- Just version -> do
- updateSetupScript version bt
- writeSetupVersionFile version
- return (version, Nothing, options)
- Nothing -> do
- savedVer <- savedVersion
- case savedVer of
- Just version | version `withinRange` useCabalVersion options ->
- do
- updateSetupScript version bt
- -- Does the previously compiled setup executable
- -- still exist and is it up-to date?
- useExisting <- canUseExistingSetup version
- if useExisting
- then return (version, Nothing, options)
- else installedVersion
- _ -> installedVersion
- where
- -- This check duplicates the checks in 'getCachedSetupExecutable' /
- -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice
- -- because the selected Cabal version may change as a result of this
- -- check.
- canUseExistingSetup :: Version -> IO Bool
- canUseExistingSetup version =
- if useCachedSetupExecutable
- then do
- (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version
- doesFileExist cachedSetupProgFile
- else
- (&&)
- <$> i setupProgFile `existsAndIsMoreRecentThan` i setupHs
- <*> i setupProgFile `existsAndIsMoreRecentThan` i setupVersionFile
-
- writeSetupVersionFile :: Version -> IO ()
- writeSetupVersionFile version =
- writeFile (i setupVersionFile) (show version ++ "\n")
-
- installedVersion
- :: IO
- ( Version
- , Maybe InstalledPackageId
- , SetupScriptOptions
- )
- installedVersion = do
- (comp, progdb, options') <- configureCompiler options
- (version, mipkgid, options'') <-
- installedCabalVersion
- options'
- comp
- progdb
- updateSetupScript version bt
- writeSetupVersionFile version
- return (version, mipkgid, options'')
-
- savedVersion :: IO (Maybe Version)
- savedVersion = do
- versionString <- readFile (i setupVersionFile) `catchIO` \_ -> return ""
- case reads versionString of
- [(version, s)] | all isSpace s -> return (Just version)
- _ -> return Nothing
-
- -- \| Update a Setup.hs script, creating it if necessary.
- updateSetupScript :: Version -> BuildType -> IO ()
- updateSetupScript _ Custom = do
- useHs <- doesFileExist customSetupHs
- useLhs <- doesFileExist customSetupLhs
- unless (useHs || useLhs) $
- dieWithException verbosity UpdateSetupScript
- let src = (if useHs then customSetupHs else customSetupLhs)
- srcNewer <- src `moreRecentFile` i setupHs
- when srcNewer $
- if useHs
- then copyFileVerbose verbosity src (i setupHs)
- else runSimplePreProcessor ppUnlit src (i setupHs) verbosity
- where
- customSetupHs = workingDir options "Setup.hs"
- customSetupLhs = workingDir options "Setup.lhs"
- updateSetupScript cabalLibVersion Hooks = do
-
- let customSetupHooks = workingDir options "SetupHooks.hs"
- useHs <- doesFileExist customSetupHooks
- unless (useHs) $
- die'
+-- | Extract the Cabal library version from 'SetupScriptOptions' if it is
+-- already determined: either by the solver via 'useDependencies', or directly
+-- via 'useCabalSpecVersion' (used for build-type: Custom packages whose
+-- setup-depends does not include a transitive Cabal dependency).
+cabalLibFromOptions
+ :: SetupScriptOptions
+ -> Maybe (Version, Maybe ComponentId)
+cabalLibFromOptions options =
+ case find (isCabalPkgId . snd) (useDependencies options) of
+ Just (unitId, pkgId) -> Just (pkgVersion pkgId, Just unitId)
+ Nothing ->
+ case useCabalSpecVersion options of
+ Just version -> Just (version, Nothing)
+ Nothing -> Nothing
+
+-- | Choose the version of Cabal to use if the setup script has a dependency
+-- on Cabal. With v2 commands, 'cabalLibFromOptions' returns 'Just ...' and
+-- we use that. With v1 commands, we fall back to a bunch of heuristics
+-- (see 'v1CabalLibVersionToUse').
+cabalLibVersionToUse
+ :: Verbosity
+ -> SetupScriptOptions
+ -> PackageId
+ -> BuildType
+ -> WantedExternalExe exe
+ -> IO (Version, Maybe ComponentId, SetupScriptOptions)
+cabalLibVersionToUse verbosity options pkgId bt wantedExe =
+ case cabalLibFromOptions options of
+ Just (version, mUnitId) -> do
+ updateSetupScript verbosity options version bt
+ writeSetupVersionFile version
+ return (version, mUnitId, options)
+ Nothing ->
+ v1CabalLibVersionToUse verbosity options pkgId bt wantedExe
+ where
+ writeSetupVersionFile :: Version -> IO ()
+ writeSetupVersionFile version =
+ writeFile
+ (interpretSymbolicPath (useWorkingDir options) (setupVersionFile options))
+ (show version ++ "\n")
+
+-- | Update a Setup.hs script, creating it if necessary.
+updateSetupScript :: Verbosity -> SetupScriptOptions -> Version -> BuildType -> IO ()
+updateSetupScript verbosity options _ Custom = do
+ useHs <- doesFileExist customSetupHs
+ useLhs <- doesFileExist customSetupLhs
+ unless (useHs || useLhs) $
+ dieWithException verbosity UpdateSetupScript
+ let src = if useHs then customSetupHs else customSetupLhs
+ srcNewer <- src `moreRecentFile` i (setupHs options)
+ when srcNewer $
+ if useHs
+ then copyFileVerbose verbosity src (i (setupHs options))
+ else runSimplePreProcessor ppUnlit src (i (setupHs options)) verbosity
+ where
+ customSetupHs = workingDir options "Setup.hs"
+ customSetupLhs = workingDir options "Setup.lhs"
+ i = interpretSymbolicPath (useWorkingDir options)
+updateSetupScript verbosity options cabalLibVersion Hooks = do
+ let customSetupHooks = workingDir options "SetupHooks.hs"
+ useHs <- doesFileExist customSetupHooks
+ unless useHs $
+ die' verbosity "Using 'build-type: Hooks' but there is no SetupHooks.hs file."
+ copyFileVerbose verbosity customSetupHooks (i (setupHooks options))
+ rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript Hooks cabalLibVersion)
+ rewriteFileLBS verbosity (i (hooksHs options)) hooksExeScript
+ where
+ i = interpretSymbolicPath (useWorkingDir options)
+updateSetupScript verbosity options cabalLibVersion bt' =
+ rewriteFileLBS verbosity (i (setupHs options)) (buildTypeScript bt' cabalLibVersion)
+ where
+ i = interpretSymbolicPath (useWorkingDir options)
+
+-- | The source code for a non-Custom 'Setup' executable.
+buildTypeScript :: BuildType -> Version -> BS.ByteString
+buildTypeScript bt cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of
+ Simple -> "import Distribution.Simple; main = defaultMain\n"
+ Configure
+ | cabalLibVersion >= mkVersion [3, 13, 0]
+ -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n"
+ | cabalLibVersion >= mkVersion [1, 3, 10]
+ -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"
+ | otherwise
+ -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"
+ Make -> "import Distribution.Make; main = defaultMain\n"
+ Hooks
+ | cabalLibVersion >= mkVersion [3, 13, 0]
+ -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n"
+ | otherwise
+ -> error "buildTypeScript Hooks with Cabal < 3.13"
+ Custom -> error "buildTypeScript Custom"
+
+-- | The source code for an external hooks executable.
+hooksExeScript :: BS.ByteString
+hooksExeScript =
+ "{-# LANGUAGE NoImplicitPrelude #-}\nimport Distribution.Simple.SetupHooks.HooksMain (hooksMain); import SetupHooks; main = hooksMain setupHooks\n"
+
+-- | Figure out which compiler we are using to compile the Setup script.
+configureCompiler
+ :: Verbosity
+ -> SetupScriptOptions
+ -> IO (Compiler, ProgramDb, SetupScriptOptions)
+configureCompiler verbosity options' = do
+ (comp, progdb) <- case useCompiler options' of
+ Just comp -> return (comp, useProgramDb options')
+ Nothing -> do
+ (comp, _, progdb) <-
+ configCompilerEx
+ (Just GHC)
+ Nothing
+ Nothing
+ (useProgramDb options')
verbosity
- "Using 'build-type: Hooks' but there is no SetupHooks.hs file."
- copyFileVerbose verbosity customSetupHooks (i setupHooks)
- rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion)
--- rewriteFileLBS verbosity hooksHs hooksScript
- updateSetupScript cabalLibVersion _ =
- rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion)
-
- buildTypeScript :: Version -> BS.ByteString
- buildTypeScript cabalLibVersion = "{-# LANGUAGE NoImplicitPrelude #-}\n" <> case bt of
- Simple -> "import Distribution.Simple; main = defaultMain\n"
- Configure
- | cabalLibVersion >= mkVersion [3, 13, 0]
- -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n"
- | cabalLibVersion >= mkVersion [1, 3, 10]
- -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"
- | otherwise
- -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"
- Make -> "import Distribution.Make; main = defaultMain\n"
- Hooks
- | cabalLibVersion >= mkVersion [3, 13, 0]
- -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n"
- | otherwise
- -> error "buildTypeScript Hooks with Cabal < 3.13"
- Custom -> error "buildTypeScript Custom"
-
- installedCabalVersion
- :: SetupScriptOptions
- -> Compiler
- -> ProgramDb
- -> IO
- ( Version
- , Maybe InstalledPackageId
- , SetupScriptOptions
- )
- installedCabalVersion options' _ _
- | packageName pkg == mkPackageName "Cabal"
- && bt == Custom =
- return (packageVersion pkg, Nothing, options')
- installedCabalVersion options' compiler progdb = do
- index <- maybeGetInstalledPackages options' compiler progdb
- let cabalDepName = mkPackageName "Cabal"
- cabalDepVersion = useCabalVersion options'
- options'' = options'{usePackageIndex = Just index}
- case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of
- [] ->
- dieWithException verbosity $ InstalledCabalVersion (packageName pkg) (useCabalVersion options)
- pkgs ->
- let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs
- err = error "Distribution.Client.installedCabalVersion: empty version list"
- in return
- ( packageVersion ipkginfo
- , Just . IPI.installedComponentId $ ipkginfo
- , options''
- )
-
- bestVersion :: (a -> Version) -> [a] -> a
- bestVersion f = firstMaximumBy (comparing (preference . f))
- where
- -- Like maximumBy, but picks the first maximum element instead of the
- -- last. In general, we expect the preferred version to go first in the
- -- list. For the default case, this has the effect of choosing the version
- -- installed in the user package DB instead of the global one. See #1463.
- --
- -- Note: firstMaximumBy could be written as just
- -- `maximumBy cmp . reverse`, but the problem is that the behaviour of
- -- maximumBy is not fully specified in the case when there is not a single
- -- greatest element.
- firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a
- firstMaximumBy _ [] =
- error "Distribution.Client.firstMaximumBy: empty list"
- firstMaximumBy cmp xs = foldl1' maxBy xs
- where
- maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y
-
- preference version =
- ( sameVersion
- , sameMajorVersion
- , stableVersion
- , latestVersion
- )
- where
- sameVersion = version == cabalVersion
- sameMajorVersion = majorVersion version == majorVersion cabalVersion
- majorVersion = take 2 . versionNumbers
- stableVersion = case versionNumbers version of
- (_ : x : _) -> even x
- _ -> False
- latestVersion = version
-
- configureCompiler
- :: SetupScriptOptions
- -> IO (Compiler, ProgramDb, SetupScriptOptions)
- configureCompiler options' = do
- (comp, progdb) <- case useCompiler options' of
- Just comp -> return (comp, useProgramDb options')
- Nothing -> do
- (comp, _, progdb) <-
- configCompilerEx
- (Just GHC)
- Nothing
- Nothing
- (useProgramDb options')
- verbosity
- return (comp, progdb)
- -- Whenever we need to call configureCompiler, we also need to access the
- -- package index, so let's cache it in SetupScriptOptions.
- index <- maybeGetInstalledPackages options' comp progdb
- return
- ( comp
- , progdb
- , options'
- { useCompiler = Just comp
- , usePackageIndex = Just index
- , useProgramDb = progdb
- }
- )
-
- -- \| Path to the setup exe cache directory and path to the cached setup
- -- executable.
- cachedSetupDirAndProg
- :: SetupScriptOptions
- -> Version
- -> IO (FilePath, FilePath)
- cachedSetupDirAndProg options' cabalLibVersion = do
- cacheDir <- defaultCacheDir
- let setupCacheDir = cacheDir "setup-exe-cache"
- cachedSetupProgFile =
- setupCacheDir
- ( "setup-"
- ++ buildTypeString
- ++ "-"
- ++ cabalVersionString
- ++ "-"
- ++ platformString
- ++ "-"
- ++ compilerVersionString
- )
- <.> exeExtension buildPlatform
- return (setupCacheDir, cachedSetupProgFile)
- where
- buildTypeString = show bt
- cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion
- compilerVersionString =
- prettyShow $
- maybe buildCompilerId compilerId $
- useCompiler options'
- platformString = prettyShow platform
-
- -- \| Look up the setup executable in the cache; update the cache if the setup
- -- executable is not found.
- getCachedSetupExecutable
- :: SetupScriptOptions
- -> Version
- -> Maybe InstalledPackageId
- -> IO FilePath
- getCachedSetupExecutable
- options'
- cabalLibVersion
- maybeCabalLibInstalledPkgId = do
- (setupCacheDir, cachedSetupProgFile) <-
- cachedSetupDirAndProg options' cabalLibVersion
- cachedSetupExists <- doesFileExist cachedSetupProgFile
- if cachedSetupExists
+ return (comp, progdb)
+ -- Whenever we need to call configureCompiler, we also need to access the
+ -- package index, so let's cache it in SetupScriptOptions.
+ index <- maybeGetInstalledPackages verbosity options' comp progdb
+ return
+ ( comp
+ , progdb
+ , options'
+ { useCompiler = Just comp
+ , usePackageIndex = Just index
+ , useProgramDb = progdb
+ }
+ )
+
+maybeGetInstalledPackages
+ :: Verbosity
+ -> SetupScriptOptions
+ -> Compiler
+ -> ProgramDb
+ -> IO InstalledPackageIndex
+maybeGetInstalledPackages verbosity options' comp progdb =
+ case usePackageIndex options' of
+ Just index -> return index
+ Nothing ->
+ getInstalledPackages
+ verbosity
+ comp
+ (usePackageDB options')
+ progdb
+
+-- | Path to the setup exe cache directory and path to the cached setup
+-- executable.
+cachedSetupDirAndProg
+ :: Platform
+ -> BuildType
+ -> SetupScriptOptions
+ -> Version
+ -> IO (FilePath, FilePath)
+cachedSetupDirAndProg platform bt options' cabalLibVersion = do
+ cacheDir <- defaultCacheDir
+ let setupCacheDir = cacheDir "setup-exe-cache"
+ cachedSetupProgFile =
+ setupCacheDir
+ ( "setup-"
+ ++ buildTypeString
+ ++ "-"
+ ++ cabalVersionString
+ ++ "-"
+ ++ platformString
+ ++ "-"
+ ++ compilerVersionString
+ )
+ <.> exeExtension buildPlatform
+ return (setupCacheDir, cachedSetupProgFile)
+ where
+ buildTypeString = show bt
+ cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion
+ compilerVersionString =
+ prettyShow $
+ maybe buildCompilerId compilerId $
+ useCompiler options'
+ platformString = prettyShow platform
+
+getCachedSetupExecutable
+ :: Verbosity
+ -> Platform
+ -> PackageIdentifier
+ -> BuildType
+ -> SetupScriptOptions
+ -> Version
+ -> Maybe ComponentId
+ -> IO FilePath
+getCachedSetupExecutable
+ verbosity
+ platform
+ pkgId
+ bt
+ options'
+ cabalLibVersion
+ maybeCabalLibInstalledPkgId = do
+ (setupCacheDir, cachedSetupProgFile) <-
+ cachedSetupDirAndProg platform bt options' cabalLibVersion
+ cachedSetupExists <- doesFileExist cachedSetupProgFile
+ if cachedSetupExists
+ then
+ debug verbosity $
+ "Found cached setup executable: " ++ cachedSetupProgFile
+ else criticalSection' $ do
+ -- The cache may have been populated while we were waiting.
+ cachedSetupExists' <- doesFileExist cachedSetupProgFile
+ if cachedSetupExists'
then
debug verbosity $
"Found cached setup executable: " ++ cachedSetupProgFile
- else criticalSection' $ do
- -- The cache may have been populated while we were waiting.
- cachedSetupExists' <- doesFileExist cachedSetupProgFile
- if cachedSetupExists'
- then
- debug verbosity $
- "Found cached setup executable: " ++ cachedSetupProgFile
- else do
- debug verbosity "Setup executable not found in the cache."
- src <-
- compileSetupExecutable
- options'
- cabalLibVersion
- maybeCabalLibInstalledPkgId
- True
- createDirectoryIfMissingVerbose verbosity True setupCacheDir
- installExecutableFile verbosity src cachedSetupProgFile
- -- Do not strip if we're using GHCJS, since the result may be a script
- when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do
- -- Add the relevant PATH overrides for the package to the
- -- program database.
- setupProgDb
- <- prependProgramSearchPath verbosity
- (useExtraPathEnv options)
- (useExtraEnvOverrides options)
- (useProgramDb options')
- >>= configureAllKnownPrograms verbosity
- Strip.stripExe
- verbosity
- platform
- setupProgDb
- cachedSetupProgFile
- return cachedSetupProgFile
- where
- criticalSection' = maybe id criticalSection $ setupCacheLock options'
-
- -- \| If the Setup.hs is out of date wrt the executable then recompile it.
- -- Currently this is GHC/GHCJS only. It should really be generalised.
- compileSetupExecutable
- :: SetupScriptOptions
- -> Version
- -> Maybe ComponentId
- -> Bool
- -> IO FilePath
- compileSetupExecutable
- options'
- cabalLibVersion
- maybeCabalLibInstalledPkgId
- forceCompile = do
- setupHsNewer <- i setupHs `moreRecentFile` i setupProgFile
- cabalVersionNewer <- i setupVersionFile `moreRecentFile` i setupProgFile
- let outOfDate = setupHsNewer || cabalVersionNewer
- when (outOfDate || forceCompile) $ do
- debug verbosity "Setup executable needs to be updated, compiling..."
- (compiler, progdb, options'') <- configureCompiler options'
- pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options''))
- let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion
- (program, extraOpts) =
- case compilerFlavor compiler of
- GHCJS -> (ghcjsProgram, ["-build-runner"])
- _ -> (ghcProgram, ["-threaded"])
- cabalDep =
- maybe
- []
- (\ipkgid -> [(ipkgid, cabalPkgid)])
- maybeCabalLibInstalledPkgId
-
- -- With 'useDependenciesExclusive' and Custom build type,
- -- we enforce the deps specified, so only the given ones can be used.
- -- Otherwise we add on a dep on the Cabal library
- -- (unless 'useDependencies' already contains one).
- selectedDeps
- | (useDependenciesExclusive options' && (bt /= Hooks))
- -- NB: to compile build-type: Hooks packages, we need Cabal
- -- in order to compile @main = defaultMainWithSetupHooks setupHooks@.
- || any (isCabalPkgId . snd) (useDependencies options')
- = useDependencies options'
- | otherwise =
- useDependencies options' ++ cabalDep
- addRenaming (ipid, _) =
- -- Assert 'DefUnitId' invariant
- ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))
- , defaultRenaming
- )
- cppMacrosFile = setupDir Cabal.Path. makeRelativePathEx "setup_macros.h"
- ghcOptions =
- mempty
- { -- Respect -v0, but don't crank up verbosity on GHC if
- -- Cabal verbosity is requested. For that, use
- -- --ghc-option=-v instead!
- ghcOptVerbosity = Flag (min (verbosityLevel verbosity) Normal)
- , ghcOptMode = Flag GhcModeMake
- , ghcOptInputFiles = toNubListR [setupHs]
- , ghcOptOutputFile = Flag setupProgFile
- , ghcOptObjDir = Flag setupDir
- , ghcOptHiDir = Flag setupDir
- , ghcOptSourcePathClear = Flag True
- , ghcOptSourcePath = case bt of
- Custom -> toNubListR [sameDirectory]
- Hooks -> toNubListR [sameDirectory]
- _ -> mempty
- , ghcOptPackageDBs = pkgDbs
- , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')
- , ghcOptCabal = Flag (useDependenciesExclusive options')
- , ghcOptPackages = toNubListR $ map addRenaming selectedDeps
- -- With 'useVersionMacros', use a version CPP macros .h file.
- , ghcOptCppIncludes =
- toNubListR
- [ cppMacrosFile
- | useVersionMacros options'
- ]
- , ghcOptExtra = extraOpts
- , ghcOptExtensions = toNubListR $
- [Simple.DisableExtension Simple.ImplicitPrelude | not (bt == Custom || any (isBasePkgId . snd) selectedDeps)]
- -- Pass -WNoImplicitPrelude to avoid depending on base
- -- when compiling a Simple Setup.hs file.
- , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler
- }
- let ghcCmdLine = renderGhcOptions compiler platform ghcOptions
- when (useVersionMacros options') $
- rewriteFileEx verbosity (i cppMacrosFile) $
- generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)
- case useLoggingHandle options of
- Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine
- -- If build logging is enabled, redirect compiler output to
- -- the log file.
- Just logHandle -> do
- output <-
- getDbProgramOutputCwd
- verbosity
- mbWorkDir
- program
- progdb
- ghcCmdLine
- hPutStr logHandle output
- return $ i setupProgFile
+ else do
+ debug verbosity "Setup executable not found in the cache."
+ src <-
+ compileExe
+ verbosity
+ platform
+ pkgId
+ bt
+ WantSetup
+ options'
+ cabalLibVersion
+ maybeCabalLibInstalledPkgId
+ True
+ createDirectoryIfMissingVerbose verbosity True setupCacheDir
+ installExecutableFile verbosity src cachedSetupProgFile
+ when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do
+ setupProgDb
+ <- prependProgramSearchPath verbosity
+ (useExtraPathEnv options')
+ (useExtraEnvOverrides options')
+ (useProgramDb options')
+ >>= configureAllKnownPrograms verbosity
+ Strip.stripExe
+ verbosity
+ platform
+ setupProgDb
+ cachedSetupProgFile
+ return cachedSetupProgFile
+ where
+ criticalSection' = maybe id criticalSection $ setupCacheLock options'
+
+-- | If the Setup.hs is out of date wrt the executable then recompile it.
+-- Currently this is GHC/GHCJS only. It should really be generalised.
+compileExe
+ :: Verbosity
+ -> Platform
+ -> PackageIdentifier
+ -> BuildType
+ -> WantedExternalExe exe
+ -> SetupScriptOptions
+ -> Version
+ -> Maybe ComponentId
+ -> Bool
+ -> IO FilePath
+compileExe verbosity platform pkgId bt wantedExe opts ver mbCompId forceCompile =
+ case wantedExe of
+ WantHooks ->
+ compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile
+ WantSetup ->
+ compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile
+
+compileSetupScript
+ :: Verbosity
+ -> Platform
+ -> PackageIdentifier
+ -> BuildType
+ -> SetupScriptOptions
+ -> Version
+ -> Maybe ComponentId
+ -> Bool
+ -> IO FilePath
+compileSetupScript verbosity platform pkgId bt opts ver mbCompId forceCompile =
+ compileSetupX "Setup"
+ [setupHs opts] (setupProgFile opts)
+ verbosity platform pkgId bt opts ver mbCompId forceCompile
+
+compileHooksScript
+ :: Verbosity
+ -> Platform
+ -> PackageIdentifier
+ -> SetupScriptOptions
+ -> Version
+ -> Maybe ComponentId
+ -> Bool
+ -> IO FilePath
+compileHooksScript verbosity platform pkgId opts ver mbCompId forceCompile =
+ compileSetupX "SetupHooks"
+ [setupHooks opts, hooksHs opts] (hooksProgFile opts)
+ verbosity platform pkgId Hooks opts ver mbCompId forceCompile
+
+setupDir :: SetupScriptOptions -> SymbolicPath Pkg (Dir setup)
+setupDir opts = useDistPref opts Cabal.Path. makeRelativePathEx "setup"
+
+setupVersionFile :: SetupScriptOptions -> SymbolicPath Pkg File
+setupVersionFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> "version")
+
+setupHs, hooksHs, setupHooks, setupProgFile, hooksProgFile :: SetupScriptOptions -> SymbolicPath Pkg File
+setupHs opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> "hs")
+hooksHs opts = setupDir opts Cabal.Path. makeRelativePathEx ("hooks" <.> "hs")
+setupHooks opts = setupDir opts Cabal.Path. makeRelativePathEx ("SetupHooks" <.> "hs")
+setupProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("setup" <.> exeExtension buildPlatform)
+hooksProgFile opts = setupDir opts Cabal.Path. makeRelativePathEx ("hooks" <.> exeExtension buildPlatform)
+
+compileSetupX
+ :: String
+ -> [SymbolicPath Pkg File]
+ -> SymbolicPath Pkg File
+ -> Verbosity
+ -> Platform
+ -> PackageIdentifier
+ -> BuildType
+ -> SetupScriptOptions
+ -> Version
+ -> Maybe ComponentId
+ -> Bool
+ -> IO FilePath
+compileSetupX
+ what
+ inPaths outPath
+ verbosity
+ platform
+ pkgId
+ bt
+ options'
+ cabalLibVersion
+ maybeCabalLibInstalledPkgId
+ forceCompile = do
+ setupXHsNewer <-
+ or <$> for inPaths (\inPath -> i inPath `moreRecentFile` i outPath)
+ cabalVersionNewer <- i (setupVersionFile options') `moreRecentFile` i outPath
+ let outOfDate = setupXHsNewer || cabalVersionNewer
+ when (outOfDate || forceCompile) $ do
+ debug verbosity $ what ++ " executable needs to be updated, compiling..."
+ (compiler, progdb, options'') <- configureCompiler verbosity options'
+ pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options''))
+ let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion
+ (program, extraOpts) =
+ case compilerFlavor compiler of
+ GHCJS -> (ghcjsProgram, ["-build-runner"])
+ _ -> (ghcProgram, ["-threaded"])
+ cabalDep =
+ maybe
+ []
+ (\ipkgid -> [(ipkgid, cabalPkgid)])
+ maybeCabalLibInstalledPkgId
+ selectedDeps
+ | (useDependenciesExclusive options' && (bt /= Hooks))
+ || any (isCabalPkgId . snd) (useDependencies options')
+ = useDependencies options'
+ | otherwise =
+ useDependencies options' ++ cabalDep
+ addRenaming (ipid, _) =
+ ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))
+ , defaultRenaming
+ )
+ cppMacrosFile = setupDir options' Cabal.Path. makeRelativePathEx "setup_macros.h"
+ ghcOptions =
+ mempty
+ { ghcOptVerbosity = Flag $ min (verbosityLevel verbosity) Normal
+ , ghcOptMode = Flag GhcModeMake
+ , ghcOptInputFiles = toNubListR inPaths
+ , ghcOptOutputFile = Flag outPath
+ , ghcOptObjDir = Flag (setupDir options')
+ , ghcOptHiDir = Flag (setupDir options')
+ , ghcOptSourcePathClear = Flag True
+ , ghcOptSourcePath = case bt of
+ Custom -> toNubListR [sameDirectory]
+ Hooks -> toNubListR [sameDirectory]
+ _ -> mempty
+ , ghcOptPackageDBs = pkgDbs
+ , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')
+ , ghcOptCabal = Flag (useDependenciesExclusive options')
+ , ghcOptPackages = toNubListR $ map addRenaming selectedDeps
+ , ghcOptCppIncludes =
+ toNubListR
+ [ cppMacrosFile
+ | useVersionMacros options'
+ ]
+ , ghcOptExtra = extraOpts
+ , ghcOptExtensions = toNubListR $
+ [ Simple.DisableExtension Simple.ImplicitPrelude
+ | not $ bt == Custom || any (isBasePkgId . snd) selectedDeps
+ ]
+ , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler
+ }
+ let ghcCmdLine = renderGhcOptions compiler platform ghcOptions
+ when (useVersionMacros options') $
+ rewriteFileEx verbosity (i cppMacrosFile) $
+ generatePackageVersionMacros (pkgVersion pkgId) (map snd selectedDeps)
+ case useLoggingHandle options' of
+ Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine
+ Just logHandle -> do
+ output <-
+ getDbProgramOutputCwd
+ verbosity
+ mbWorkDir
+ program
+ progdb
+ ghcCmdLine
+ hPutStr logHandle output
+ return $ i outPath
+ where
+ mbWorkDir = useWorkingDir options'
+ i :: SymbolicPathX allowAbs Pkg to -> FilePath
+ i = interpretSymbolicPath mbWorkDir
isCabalPkgId, isBasePkgId :: PackageIdentifier -> Bool
isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
isBasePkgId (PackageIdentifier pname _) = pname == mkPackageName "base"
+
+--------------------------------------------------------------------------------
+-- THE FORSAKEN ZONE: v1-only logic
+--
+-- Hopefully we can get rid of all of this before long, simplifying this
+-- annoyingly complex module.
+--
+-- The v1 code path corresponds to 'useDependencies' being unset
+-- (no pre-computed dependencies by the solver).
+
+-- | **v1-only**
+--
+-- Fallback logic to find which Cabal library version to use: try the previously
+-- saved version first, then search for available versions in the installed
+-- package index, picking a "best" option heuristically.
+v1CabalLibVersionToUse
+ :: Verbosity
+ -> SetupScriptOptions
+ -> PackageId
+ -> BuildType
+ -> WantedExternalExe exe
+ -> IO (Version, Maybe ComponentId, SetupScriptOptions)
+v1CabalLibVersionToUse verbosity options pkgId bt wantedExe = do
+ savedVer <- savedVersion
+ case savedVer of
+ Just version | version `withinRange` useCabalVersion options ->
+ do
+ updateSetupScript verbosity options version bt
+ -- Does the previously compiled setup executable
+ -- still exist and is it up-to date?
+ useExisting <- canUseExistingSetup version
+ if useExisting
+ then return (version, Nothing, options)
+ else installedVersion
+ _ -> installedVersion
+ where
+ platform = fromMaybe buildPlatform (usePlatform options)
+
+ i :: SymbolicPath Pkg File -> FilePath
+ i = interpretSymbolicPath (useWorkingDir options)
+
+ writeSetupVersionFile :: Version -> IO ()
+ writeSetupVersionFile version =
+ writeFile (i (setupVersionFile options)) (show version ++ "\n")
+
+ savedVersion :: IO (Maybe Version)
+ savedVersion = do
+ versionString <- readFile (i (setupVersionFile options)) `catchIO` \_ -> return ""
+ case reads versionString of
+ [(version, s)] | all isSpace s -> return (Just version)
+ _ -> return Nothing
+
+ -- This check duplicates the checks in 'getCachedSetupExecutable' /
+ -- 'compileExe'. Unfortunately, we have to perform it twice because the
+ -- selected Cabal version may change as a result of this check.
+ canUseExistingSetup :: Version -> IO Bool
+ canUseExistingSetup version =
+ if useCachedSetupExecutable bt
+ then do
+ (_, cachedSetupProgFile) <- cachedSetupDirAndProg platform bt options version
+ doesFileExist cachedSetupProgFile
+ else case wantedExe of
+ WantSetup ->
+ (&&)
+ <$> i (setupProgFile options) `existsAndIsMoreRecentThan` i (setupHs options)
+ <*> i (setupProgFile options) `existsAndIsMoreRecentThan` i (setupVersionFile options)
+ WantHooks ->
+ (&&)
+ <$> i (hooksProgFile options) `existsAndIsMoreRecentThan` i (setupHooks options)
+ <*> i (hooksProgFile options) `existsAndIsMoreRecentThan` i (setupVersionFile options)
+
+ installedVersion :: IO (Version, Maybe ComponentId, SetupScriptOptions)
+ installedVersion = do
+ (comp, progdb, options') <- configureCompiler verbosity options
+ (version, mipkgid, options'') <-
+ installedCabalVersion verbosity pkgId bt options' comp progdb
+ updateSetupScript verbosity options version bt
+ writeSetupVersionFile version
+ return (version, mipkgid, options'')
+
+-- | **v1-only**
+--
+-- Find the version of the installed @Cabal@ package that satisfies the
+-- version range in 'useCabalVersion'.
+installedCabalVersion
+ :: Verbosity
+ -> PackageId
+ -> BuildType
+ -> SetupScriptOptions
+ -> Compiler
+ -> ProgramDb
+ -> IO
+ ( Version
+ , Maybe InstalledPackageId
+ , SetupScriptOptions
+ )
+installedCabalVersion _verbosity pkgId bt options' _ _
+ | packageName pkgId == mkPackageName "Cabal"
+ && bt == Custom =
+ return (packageVersion pkgId, Nothing, options')
+installedCabalVersion verbosity pkgId _bt options' compiler progdb = do
+ index <- maybeGetInstalledPackages verbosity options' compiler progdb
+ let cabalDepName = mkPackageName "Cabal"
+ cabalDepVersion = useCabalVersion options'
+ options'' = options'{usePackageIndex = Just index}
+ case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of
+ [] ->
+ dieWithException verbosity $ InstalledCabalVersion (packageName pkgId) (useCabalVersion options')
+ pkgs ->
+ let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs
+ err = error "Distribution.Client.installedCabalVersion: empty version list"
+ in return
+ ( packageVersion ipkginfo
+ , Just . IPI.installedComponentId $ ipkginfo
+ , options''
+ )
+
+-- | **v1-only**
+--
+-- Pick the best version from a non-empty list, preferring the one that
+-- matches or is closest to the currently running @cabal-install@\'s own
+-- @Cabal@ library version.
+bestVersion :: (a -> Version) -> [a] -> a
+bestVersion f = firstMaximumBy (comparing (preference . f))
+ where
+ -- Like maximumBy, but picks the first maximum element instead of the
+ -- last. In general, we expect the preferred version to go first in the
+ -- list. For the default case, this has the effect of choosing the version
+ -- installed in the user package DB instead of the global one. See #1463.
+ --
+ -- Note: firstMaximumBy could be written as just
+ -- `maximumBy cmp . reverse`, but the problem is that the behaviour of
+ -- maximumBy is not fully specified in the case when there is not a single
+ -- greatest element.
+ firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a
+ firstMaximumBy _ [] =
+ error "Distribution.Client.firstMaximumBy: empty list"
+ firstMaximumBy cmp xs = foldl1' maxBy xs
+ where
+ maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y
+
+ preference version =
+ ( sameVersion
+ , sameMajorVersion
+ , stableVersion
+ , latestVersion
+ )
+ where
+ sameVersion = version == cabalVersion
+ sameMajorVersion = majorVersion version == majorVersion cabalVersion
+ majorVersion = take 2 . versionNumbers
+ stableVersion = case versionNumbers version of
+ (_ : x : _) -> even x
+ _ -> False
+ latestVersion = version
+
+-- End of v1-only logic
+--------------------------------------------------------------------------------
diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
index c0f1ff4dd2c..b1f04f0e57e 100644
--- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
+++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
@@ -56,11 +56,7 @@ import Prelude ()
import Distribution.Package
( HasUnitId (..)
, Package (..)
- , PackageId
, PackageIdentifier (..)
- , PackageName
- , packageName
- , packageVersion
)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Types.Flag (nullFlagAssignment)
@@ -68,10 +64,8 @@ import Distribution.Types.Flag (nullFlagAssignment)
import Distribution.Client.Types
( UnresolvedPkgLoc
)
-import Distribution.Version
- ( Version
- )
+import Distribution.Solver.Types.PackagePath (QPN)
import Distribution.Solver.Types.ResolverPackage
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
@@ -80,9 +74,11 @@ import Distribution.Solver.Types.SolverPackage
import Data.Array ((!))
import qualified Data.Foldable as Foldable
import qualified Data.Graph as OldGraph
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Distribution.Compat.Graph (Graph, IsNode (..))
import qualified Distribution.Compat.Graph as Graph
+import GHC.Stack (HasCallStack)
type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc
@@ -94,18 +90,6 @@ data SolverInstallPlan = SolverInstallPlan
}
deriving (Generic)
-{-
--- | Much like 'planPkgIdOf', but mapping back to full packages.
-planPkgOf :: SolverInstallPlan
- -> Graph.Vertex
- -> SolverPlanPackage
-planPkgOf plan v =
- case Graph.lookupKey (planIndex plan)
- (planPkgIdOf plan v) of
- Just pkg -> pkg
- Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed"
--}
-
instance Binary SolverInstallPlan
instance Structured SolverInstallPlan
@@ -162,7 +146,8 @@ toMap = Graph.toMap . planIndex
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
remove
- :: (SolverPlanPackage -> Bool)
+ :: HasCallStack
+ => (SolverPlanPackage -> Bool)
-> SolverInstallPlan
-> Either
[SolverPlanProblem]
@@ -195,9 +180,9 @@ valid indepGoals index =
data SolverPlanProblem
= PackageMissingDeps
SolverPlanPackage
- [PackageIdentifier]
+ (NE.NonEmpty PackageIdentifier)
| PackageCycle [SolverPlanPackage]
- | PackageInconsistency PackageName [(PackageIdentifier, Version)]
+ | PackageInconsistency QPN [(SolverId, SolverId)]
| PackageStateInvalid SolverPlanPackage SolverPlanPackage
showPlanProblem :: SolverPlanProblem -> String
@@ -205,7 +190,7 @@ showPlanProblem (PackageMissingDeps pkg missingDeps) =
"Package "
++ prettyShow (packageId pkg)
++ " depends on the following packages which are missing from the plan: "
- ++ intercalate ", " (map prettyShow missingDeps)
+ ++ intercalate ", " (map prettyShow (NE.toList missingDeps))
showPlanProblem (PackageCycle cycleGroup) =
"The following packages are involved in a dependency cycle "
++ intercalate ", " (map (prettyShow . packageId) cycleGroup)
@@ -218,7 +203,7 @@ showPlanProblem (PackageInconsistency name inconsistencies) =
[ " package "
++ prettyShow pkg
++ " requires "
- ++ prettyShow (PackageIdentifier name ver)
+ ++ prettyShow ver
| (pkg, ver) <- inconsistencies
]
showPlanProblem (PackageStateInvalid pkg pkg') =
@@ -242,13 +227,14 @@ problems
:: IndependentGoals
-> SolverPlanIndex
-> [SolverPlanProblem]
-problems indepGoals index =
+problems _indepGoals index =
[ PackageMissingDeps
pkg
- ( mapMaybe
- (fmap packageId . flip Graph.lookup index)
- missingDeps
- )
+ -- ( mapMaybe
+ -- (fmap packageId . flip Graph.lookup index)
+ -- missingDeps
+ -- )
+ (NE.map (packageId . fromMaybe (error "should not happen") . flip Graph.lookup index) missingDeps)
| (pkg, missingDeps) <- Graph.broken index
]
++ [ PackageCycle cycleGroup
@@ -256,7 +242,7 @@ problems indepGoals index =
]
++ [ PackageInconsistency name inconsistencies
| (name, inconsistencies) <-
- dependencyInconsistencies indepGoals index
+ dependencyInconsistencies index
]
++ [ PackageStateInvalid pkg pkg'
| pkg <- Foldable.toList index
@@ -275,10 +261,9 @@ problems indepGoals index =
-- cycle. Such cycles may or may not be an issue; either way, we don't check
-- for them here.
dependencyInconsistencies
- :: IndependentGoals
- -> SolverPlanIndex
- -> [(PackageName, [(PackageIdentifier, Version)])]
-dependencyInconsistencies indepGoals index =
+ :: SolverPlanIndex
+ -> [(QPN, [(SolverId, SolverId)])]
+dependencyInconsistencies index =
concatMap dependencyInconsistencies' subplans
where
subplans :: [SolverPlanIndex]
@@ -286,7 +271,7 @@ dependencyInconsistencies indepGoals index =
-- Not Graph.closure!!
map
(nonSetupClosure index)
- (rootSets indepGoals index)
+ (rootSets (IndependentGoals False) index)
-- NB: When we check for inconsistencies, packages from the setup
-- scripts don't count as part of the closure (this way, we
@@ -335,6 +320,8 @@ rootSets (IndependentGoals indepGoals) index =
--
-- The library roots are the set of packages with no reverse dependencies
-- (no reverse library dependencies but also no reverse setup dependencies).
+--
+-- FIXME: misleading name, this includes executables too!
libraryRoots :: SolverPlanIndex -> [SolverId]
libraryRoots index =
map (nodeKey . toPkgId) roots
@@ -362,9 +349,14 @@ setupRoots =
-- distinct.
dependencyInconsistencies'
:: SolverPlanIndex
- -> [(PackageName, [(PackageIdentifier, Version)])]
+ -> [(QPN, [(SolverId, SolverId)])]
dependencyInconsistencies' index =
- [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids])
+ [ ( name
+ , [ (sid, solverId dep)
+ | (dep, sids) <- uses
+ , sid <- sids
+ ]
+ )
| (name, ipid_map) <- Map.toList inverseIndex
, let uses = Map.elems ipid_map
, reallyIsInconsistent (map fst uses)
@@ -374,11 +366,11 @@ dependencyInconsistencies' index =
-- and each installed ID of that package
-- the associated package instance
-- and a list of reverse dependencies (as source IDs)
- inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId]))
+ inverseIndex :: Map QPN (Map SolverId (SolverPlanPackage, [SolverId]))
inverseIndex =
Map.fromListWith
(Map.unionWith (\(a, b) (_, b') -> (a, b ++ b')))
- [ (packageName dep, Map.fromList [(sid, (dep, [packageId pkg]))])
+ [ (solverQPN dep, Map.fromList [(sid, (dep, [solverId pkg]))])
| -- For each package @pkg@
pkg <- Foldable.toList index
, -- Find out which @sid@ @pkg@ depends on
@@ -434,7 +426,7 @@ closed = null . Graph.broken
-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to
-- find out which packages are.
consistent :: SolverPlanIndex -> Bool
-consistent = null . dependencyInconsistencies (IndependentGoals False)
+consistent = null . dependencyInconsistencies
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs
index 9e57595bb95..a324356d9cb 100644
--- a/cabal-install/src/Distribution/Client/SourceFiles.hs
+++ b/cabal-install/src/Distribution/Client/SourceFiles.hs
@@ -81,7 +81,9 @@ needComponent pkg_descr comp =
CBench bench -> needBenchmark pkg_descr bench
needSetup :: Rebuild ()
-needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return ()
+needSetup = do
+ void $ findFirstFileMonitored id ["Setup.hs", "Setup.lhs"]
+ void $ findFirstFileMonitored id ["SetupHooks.hs", "SetupHooks.lhs"]
needLibrary :: PackageDescription -> Library -> Rebuild ()
needLibrary
diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs
index 56ea25d958e..ffd53651f8d 100644
--- a/cabal-install/src/Distribution/Client/TargetSelector.hs
+++ b/cabal-install/src/Distribution/Client/TargetSelector.hs
@@ -1,10 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
--- TODO
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
@@ -165,8 +165,8 @@ import qualified Prelude (foldr1)
-- ------------------------------------------------------------
--- | A target selector is expression selecting a set of components (as targets
--- for a actions like @build@, @run@, @test@ etc). A target selector
+-- | A target selector is an expression selecting a set of components (as targets
+-- for actions like @build@, @run@, @test@ etc). A target selector
-- corresponds to the user syntax for referring to targets on the command line.
--
-- From the users point of view a target can be many things: packages, dirs,
@@ -765,9 +765,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
Left
( originalMatch
, [ (forgetFileStatus rendering, matches)
- | rendering <- matchRenderings
- , let Match m _ matches =
- memoisedMatches Map.! rendering
+ | rendering@((memoisedMatches Map.!?) -> Just (Match m _ matches)) <- matchRenderings
, m /= Inexact
]
)
@@ -1107,7 +1105,7 @@ syntaxForm1File ps =
-- all the other forms we don't require that.
syntaxForm1 render $ \str1 fstatus1 ->
expecting "file" str1 $ do
- (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) <-
+ (pkgfile, KnownPackage{pinfoId, pinfoComponents}) <-
-- always returns the KnownPackage case
matchPackageDirectoryPrefix ps fstatus1
orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
@@ -1134,7 +1132,7 @@ syntaxForm2MetaAll =
[TargetStringFileStatus2 "" noFileStatus "all"]
render _ = []
--- | Syntax: all : filer
+-- | Syntax: all : filter
--
-- > cabal build all:tests
syntaxForm2AllFilter :: Syntax
@@ -1148,7 +1146,7 @@ syntaxForm2AllFilter =
[TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)]
render _ = []
--- | Syntax: package : filer
+-- | Syntax: package : filter
--
-- > cabal build foo:tests
syntaxForm2PackageFilter :: [KnownPackage] -> Syntax
@@ -1722,44 +1720,41 @@ syntaxForm3 :: Renderer -> Match3 -> Syntax
syntaxForm4 :: Renderer -> Match4 -> Syntax
syntaxForm5 :: Renderer -> Match5 -> Syntax
syntaxForm7 :: Renderer -> Match7 -> Syntax
-syntaxForm1 render f =
- Syntax QL1 match render
+syntaxForm1 render f = Syntax QL1 match render
where
- match = \(TargetStringFileStatus1 str1 fstatus1) ->
- f str1 fstatus1
+ match = \case
+ TargetStringFileStatus1 str1 fstatus1 -> f str1 fstatus1
+ _ -> mzero
-syntaxForm2 render f =
- Syntax QL2 match render
+syntaxForm2 render f = Syntax QL2 match render
where
- match = \(TargetStringFileStatus2 str1 fstatus1 str2) ->
- f str1 fstatus1 str2
+ match = \case
+ TargetStringFileStatus2 str1 fstatus1 str2 -> f str1 fstatus1 str2
+ _ -> mzero
-syntaxForm3 render f =
- Syntax QL3 match render
+syntaxForm3 render f = Syntax QL3 match render
where
- match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) ->
- f str1 fstatus1 str2 str3
+ match = \case
+ TargetStringFileStatus3 str1 fstatus1 str2 str3 -> f str1 fstatus1 str2 str3
+ _ -> mzero
-syntaxForm4 render f =
- Syntax QLFull match render
+syntaxForm4 render f = Syntax QLFull match render
where
- match (TargetStringFileStatus4 str1 str2 str3 str4) =
- f str1 str2 str3 str4
- match _ = mzero
+ match = \case
+ TargetStringFileStatus4 str1 str2 str3 str4 -> f str1 str2 str3 str4
+ _ -> mzero
-syntaxForm5 render f =
- Syntax QLFull match render
+syntaxForm5 render f = Syntax QLFull match render
where
- match (TargetStringFileStatus5 str1 str2 str3 str4 str5) =
- f str1 str2 str3 str4 str5
- match _ = mzero
+ match = \case
+ TargetStringFileStatus5 str1 str2 str3 str4 str5 -> f str1 str2 str3 str4 str5
+ _ -> mzero
-syntaxForm7 render f =
- Syntax QLFull match render
+syntaxForm7 render f = Syntax QLFull match render
where
- match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) =
- f str1 str2 str3 str4 str5 str6 str7
- match _ = mzero
+ match = \case
+ TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7 -> f str1 str2 str3 str4 str5 str6 str7
+ _ -> mzero
dispP :: Package p => p -> String
dispP = prettyShow . packageName
@@ -2391,6 +2386,9 @@ instance MonadPlus Match where
mzero = empty
mplus = matchPlus
+instance MonadFail Match where
+ fail _ = mzero
+
() :: Match a -> Match a -> Match a
() = matchPlusShadowing
diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs
index b56c8828532..d5db171187c 100644
--- a/cabal-install/src/Distribution/Client/Targets.hs
+++ b/cabal-install/src/Distribution/Client/Targets.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
@@ -34,7 +35,8 @@ module Distribution.Client.Targets
-- * User constraints
, UserQualifier (..)
, UserConstraintScope (..)
- , UserConstraint (..)
+ , UserConstraintQualifier (..)
+ , UserConstraint (UserConstraint, UserConstraintStaged)
, userConstraintPackageName
, readUserConstraint
, userToPackageConstraint
@@ -99,6 +101,7 @@ import qualified Data.Map as Map
import Distribution.Client.Errors
import qualified Distribution.Client.GZipUtils as GZipUtils
import qualified Distribution.Compat.CharParsing as P
+import Distribution.Solver.Types.Stage (Stage)
import Distribution.Utils.Path (makeSymbolicPath)
import Network.URI
( URI (..)
@@ -164,10 +167,7 @@ data UserTarget
readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
readUserTargets verbosity targetStrs = do
- (problems, targets) <-
- liftM
- partitionEithers
- (traverse readUserTarget targetStrs)
+ (problems, targets) <- partitionEithers <$> traverse readUserTarget targetStrs
reportUserTargetProblems verbosity problems
return targets
@@ -614,18 +614,27 @@ instance Structured UserQualifier
-- | Version of 'ConstraintScope' that a user may specify on the
-- command line.
-data UserConstraintScope
+data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQualifier
+ deriving (Eq, Show, Generic)
+
+instance Binary UserConstraintScope
+instance Structured UserConstraintScope
+instance NFData UserConstraintScope
+
+data UserConstraintQualifier
= -- | Scope that applies to the package when it has the specified qualifier.
UserQualified UserQualifier PackageName
| -- | Scope that applies to the package when it has a setup qualifier.
UserAnySetupQualifier PackageName
+ | -- | Scope that applies to the package when it has a setup qualifier.
+ UserAnyExeQualifier PackageName
| -- | Scope that applies to the package when it has any qualifier.
UserAnyQualifier PackageName
deriving (Eq, Show, Generic)
-instance Binary UserConstraintScope
-instance NFData UserConstraintScope
-instance Structured UserConstraintScope
+instance Binary UserConstraintQualifier
+instance Structured UserConstraintQualifier
+instance NFData UserConstraintQualifier
fromUserQualifier :: UserQualifier -> Qualifier
fromUserQualifier UserQualToplevel = QualToplevel
@@ -633,30 +642,41 @@ fromUserQualifier (UserQualSetup name) = QualSetup name
fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2
fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
-fromUserConstraintScope (UserQualified q pn) =
- ScopeQualified (fromUserQualifier q) pn
-fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn
-fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn
+fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) =
+ ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn)
+fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) =
+ ConstraintScope mstage (ScopeAnySetupQualifier pn)
+fromUserConstraintScope (UserConstraintScope mstage (UserAnyExeQualifier pn)) =
+ ConstraintScope mstage (ScopeAnyExeQualifier pn)
+fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) =
+ ConstraintScope mstage (ScopeAnyQualifier pn)
-- | Version of 'PackageConstraint' that the user can specify on
-- the command line.
data UserConstraint
- = UserConstraint UserConstraintScope PackageProperty
+ = UserConstraintX UserConstraintScope PackageProperty
deriving (Eq, Show, Generic)
instance Binary UserConstraint
instance NFData UserConstraint
instance Structured UserConstraint
+pattern UserConstraint :: UserConstraintQualifier -> PackageProperty -> UserConstraint
+pattern UserConstraint qualifier prop = UserConstraintX (UserConstraintScope Nothing qualifier) prop
+
+pattern UserConstraintStaged :: Stage -> UserConstraintQualifier -> PackageProperty -> UserConstraint
+pattern UserConstraintStaged stage qualifier prop = UserConstraintX (UserConstraintScope (Just stage) qualifier) prop
+
userConstraintPackageName :: UserConstraint -> PackageName
-userConstraintPackageName (UserConstraint scope _) = scopePN scope
+userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier) _) = scopePN qualifier
where
scopePN (UserQualified _ pn) = pn
scopePN (UserAnyQualifier pn) = pn
scopePN (UserAnySetupQualifier pn) = pn
+ scopePN (UserAnyExeQualifier pn) = pn
userToPackageConstraint :: UserConstraint -> PackageConstraint
-userToPackageConstraint (UserConstraint scope prop) =
+userToPackageConstraint (UserConstraintX scope prop) =
PackageConstraint (fromUserConstraintScope scope) prop
readUserConstraint :: String -> Either String UserConstraint
@@ -671,7 +691,7 @@ readUserConstraint str =
++ "'source', 'test', 'bench', or flags. "
instance Pretty UserConstraint where
- pretty (UserConstraint scope prop) =
+ pretty (UserConstraintX scope prop) =
pretty $ PackageConstraint (fromUserConstraintScope scope) prop
instance Parsec UserConstraint where
@@ -687,25 +707,60 @@ instance Parsec UserConstraint where
, PackagePropertyStanzas [TestStanzas] <$ P.string "test"
, PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"
]
- return (UserConstraint scope prop)
+ return (UserConstraintX scope prop)
where
parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
parseConstraintScope = do
+ mstage <- P.optional (P.try (parsec <* P.char ':'))
pn <- parsec
- P.choice
- [ P.char '.' *> withDot pn
- , P.char ':' *> withColon pn
- , return (UserQualified UserQualToplevel pn)
- ]
+ c <-
+ P.choice
+ [ P.char '.' *> withDot pn
+ , P.char ':' *> withColon pn
+ , return (UserQualified UserQualToplevel pn)
+ ]
+ return $ UserConstraintScope mstage c
where
- withDot :: PackageName -> m UserConstraintScope
+ withDot :: PackageName -> m UserConstraintQualifier
withDot pn
| pn == mkPackageName "any" = UserAnyQualifier <$> parsec
| pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
+ | pn == mkPackageName "exe" = UserAnyExeQualifier <$> parsec
| otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
- withColon :: PackageName -> m UserConstraintScope
+ withColon :: PackageName -> m UserConstraintQualifier
withColon pn =
- UserQualified (UserQualSetup pn)
- <$ P.string "setup."
- <*> parsec
+ P.choice
+ [ UserQualified (UserQualSetup pn) <$> (P.string "setup." *> parsec)
+ , UserQualified . UserQualExe pn <$> (P.string "exe:" *> parsec) <*> (P.char '.' *> parsec)
+ ]
+
+-- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "any.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "setup.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "exe.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyExeQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
+--
+-- >>> eitherParsec "build:rts source" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource)
+--
+-- >>> eitherParsec "build:any.rts source" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserAnyQualifier (PackageName "rts"))) PackagePropertySource)
+--
+-- >>> eitherParsec "setup.ghc-internal installed" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "ghc-internal"))) PackagePropertyInstalled)
+--
+-- >>> eitherParsec "foo:exe:bar.baz > 1.2.3.4" :: Either String UserConstraint
+-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "baz"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs
new file mode 100644
index 00000000000..f64c85a2221
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/Toolchain.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Distribution.Client.Toolchain
+ ( Stage (..)
+ , Staged (..)
+ , Toolchain (..)
+ , mkProgramDb
+ , configToolchain
+ , configToolchains
+ , module Distribution.Solver.Types.Stage
+ , module Distribution.Solver.Types.Toolchain
+ )
+where
+
+import Distribution.Client.Setup (ConfigExFlags (..))
+import Distribution.Simple (Compiler, CompilerFlavor)
+import Distribution.Simple.Compiler (interpretPackageDBStack)
+import Distribution.Simple.Configure hiding (mkProgramDb)
+import Distribution.Simple.Program (ProgArg)
+import Distribution.Simple.Program.Db
+import Distribution.Simple.Setup
+import Distribution.Solver.Types.Stage
+import Distribution.Solver.Types.Toolchain
+import Distribution.System (Platform)
+import Distribution.Utils.NubList
+import Distribution.Verbosity (Verbosity, defaultVerbosityHandles, mkVerbosity)
+
+mkProgramDb
+ :: Verbosity
+ -> [FilePath]
+ -> [(String, FilePath)]
+ -> [(String, [ProgArg])]
+ -> IO ProgramDb
+mkProgramDb verbosity extraSearchPath extraPaths extraArgs = do
+ progdb <- prependProgramSearchPath verbosity extraSearchPath [] defaultProgramDb
+ -- ProgramDb with directly user specified paths
+ return $
+ userSpecifyPaths extraPaths $
+ userSpecifyArgss extraArgs progdb
+
+-- | Configure the toolchain
+configToolchain :: ConfigFlags -> IO Toolchain
+configToolchain configFlags@ConfigFlags{..} = do
+ programDb <-
+ mkProgramDb
+ verbosity
+ (fromNubList configProgramPathExtra)
+ configProgramPaths
+ configProgramArgs
+
+ (toolchainCompiler, toolchainPlatform, progdb) <-
+ configCompilerEx
+ (flagToMaybe configHcFlavor)
+ (flagToMaybe configHcPath)
+ (flagToMaybe configHcPkg)
+ programDb
+ verbosity
+
+ -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the
+ -- future.
+ toolchainProgramDb <- configureAllKnownPrograms verbosity progdb
+ let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs
+
+ return Toolchain{..}
+ where
+ -- FIXME
+ verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (configVerbosity configFlags))
+
+configToolchains :: Verbosity -> ConfigFlags -> ConfigExFlags -> IO (Staged Toolchain)
+configToolchains verbosity ConfigFlags{..} ConfigExFlags{..} = do
+ programDb <-
+ mkProgramDb
+ verbosity
+ (fromNubList configProgramPathExtra)
+ configProgramPaths
+ configProgramArgs
+
+ hostToolchain <- do
+ (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <-
+ configCompilerExSafe
+ verbosity
+ (flagToMaybe configHcFlavor)
+ (flagToMaybe configHcPath)
+ (flagToMaybe configHcPkg)
+ programDb
+ let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs
+ return Toolchain{..}
+
+ buildToolchain <- do
+ (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <-
+ configCompilerExSafe
+ verbosity
+ (flagToMaybe configBuildHcFlavor)
+ (flagToMaybe configBuildHcPath)
+ (flagToMaybe configBuildHcPkg)
+ programDb
+ let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs
+ return Toolchain{..}
+
+ return $ Staged (\case Build -> buildToolchain; Host -> hostToolchain)
+
+configCompilerExSafe
+ :: Verbosity
+ -> Maybe CompilerFlavor
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> ProgramDb
+ -> IO (Compiler, Platform, ProgramDb)
+configCompilerExSafe verbosity hcFlavor hcPath hcPkg progdb = do
+ (compiler, platform, progdb') <-
+ configCompilerEx
+ hcFlavor
+ hcPath
+ hcPkg
+ progdb
+ verbosity
+
+ -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future.
+ -- I think this should be fixed in configCompilerExAux or even configCompilerEx
+ progdb'' <- configureAllKnownPrograms verbosity progdb'
+ return (compiler, platform, progdb'')
diff --git a/cabal-install/src/Distribution/Client/Types.hs b/cabal-install/src/Distribution/Client/Types.hs
index 841a4dbc9d2..e8647b1edb5 100644
--- a/cabal-install/src/Distribution/Client/Types.hs
+++ b/cabal-install/src/Distribution/Client/Types.hs
@@ -22,7 +22,7 @@ module Distribution.Client.Types
, module Distribution.Client.Types.BuildResults
, module Distribution.Client.Types.PackageLocation
, module Distribution.Client.Types.PackageSpecifier
- , module Distribution.Client.Types.ReadyPackage
+ , module Distribution.Client.Types.GenericReadyPackage
, module Distribution.Client.Types.Repo
, module Distribution.Client.Types.RepoName
, module Distribution.Client.Types.SourcePackageDb
@@ -33,9 +33,9 @@ import Distribution.Client.Types.AllowNewer
import Distribution.Client.Types.BuildResults
import Distribution.Client.Types.ConfiguredId
import Distribution.Client.Types.ConfiguredPackage
+import Distribution.Client.Types.GenericReadyPackage
import Distribution.Client.Types.PackageLocation
import Distribution.Client.Types.PackageSpecifier
-import Distribution.Client.Types.ReadyPackage
import Distribution.Client.Types.Repo
import Distribution.Client.Types.RepoName
import Distribution.Client.Types.SourcePackageDb
diff --git a/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs b/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs
index 0b7d62e7e77..ebd2a13c733 100644
--- a/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs
+++ b/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs
@@ -16,6 +16,7 @@ import Distribution.Types.Flag (FlagAssignment)
import Distribution.Types.LibraryName (LibraryName (..))
import Distribution.Types.MungedPackageId (computeCompatPackageId)
+import Data.Foldable (fold)
import Distribution.Client.Types.ConfiguredId
import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet)
import Distribution.Solver.Types.PackageFixedDeps
@@ -65,7 +66,7 @@ instance IsNode (ConfiguredPackage loc) where
-- TODO: if we update ConfiguredPackage to support order-only
-- dependencies, need to include those here.
-- NB: have to deduplicate, otherwise the planner gets confused
- nodeNeighbors = ordNub . CD.flatDeps . depends
+ nodeNeighbors = ordNub . fold . depends
instance Binary loc => Binary (ConfiguredPackage loc)
@@ -80,4 +81,4 @@ instance HasUnitId (ConfiguredPackage loc) where
installedUnitId = newSimpleUnitId . confPkgId
instance PackageInstalled (ConfiguredPackage loc) where
- installedDepends = CD.flatDeps . depends
+ installedDepends = fold . depends
diff --git a/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs
new file mode 100644
index 00000000000..a8b673cb36b
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Client.Types.GenericReadyPackage
+ ( GenericReadyPackage (..)
+ ) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.Compat.Graph (IsNode (..))
+import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled)
+
+import Distribution.Solver.Types.PackageFixedDeps
+
+-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
+-- installed already, hence itself ready to be installed.
+newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.
+ deriving
+ ( Eq
+ , Show
+ , Generic
+ , Package
+ , PackageFixedDeps
+ , HasMungedPackageId
+ , HasUnitId
+ , PackageInstalled
+ , Binary
+ )
+
+-- Can't newtype derive this
+instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where
+ type Key (GenericReadyPackage srcpkg) = Key srcpkg
+ nodeKey (ReadyPackage spkg) = nodeKey spkg
+ nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg
diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs
index 6c8ac9b3966..c4f3362b4e3 100644
--- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs
+++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs
@@ -52,7 +52,7 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) =
where
pc =
PackageConstraint
- (ScopeTarget $ packageName pkg)
+ (scopeToplevel (packageName pkg))
(PackagePropertyVersion $ thisVersion (packageVersion pkg))
mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg
diff --git a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs
index e04b5af79c8..5eeb8e5e194 100644
--- a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs
+++ b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs
@@ -1,41 +1,10 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-
module Distribution.Client.Types.ReadyPackage
( GenericReadyPackage (..)
, ReadyPackage
) where
-import Distribution.Client.Compat.Prelude
-import Prelude ()
-
-import Distribution.Compat.Graph (IsNode (..))
-import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled)
-
import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage)
+import Distribution.Client.Types.GenericReadyPackage (GenericReadyPackage (..))
import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc)
-import Distribution.Solver.Types.PackageFixedDeps
-
--- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
--- installed already, hence itself ready to be installed.
-newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.
- deriving
- ( Eq
- , Show
- , Generic
- , Package
- , PackageFixedDeps
- , HasMungedPackageId
- , HasUnitId
- , PackageInstalled
- , Binary
- )
-
--- Can't newtype derive this
-instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where
- type Key (GenericReadyPackage srcpkg) = Key srcpkg
- nodeKey (ReadyPackage spkg) = nodeKey spkg
- nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg
type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs
index 756ab2469dc..e5676d2b3f5 100644
--- a/cabal-install/src/Distribution/Client/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Utils.hs
@@ -15,7 +15,6 @@ module Distribution.Client.Utils
, withExtraPathEnv
, determineNumJobs
, numberOfProcessors
- , removeExistingFile
, withTempFileName
, makeAbsoluteToCwd
, makeRelativeToCwd
@@ -71,7 +70,7 @@ import Distribution.Client.Errors
import Distribution.Compat.Environment
import Distribution.Compat.Time (getModTime)
import Distribution.Simple.Setup (Flag, pattern Flag, pattern NoFlag)
-import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)
+import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap, removeFileForcibly)
import Distribution.Utils.Path
( CWD
, FileOrDir (..)
@@ -91,7 +90,6 @@ import System.Directory
, doesDirectoryExist
, doesFileExist
, listDirectory
- , removeFile
)
import qualified System.Directory as Directory
import System.FilePath
@@ -151,14 +149,6 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
moreThanOne (_ : _ : _) = True
moreThanOne _ = False
--- | Like 'removeFile', but does not throw an exception when the file does not
--- exist.
-removeExistingFile :: FilePath -> IO ()
-removeExistingFile path = do
- exists <- doesFileExist path
- when exists $
- removeFile path
-
-- | A variant of 'withTempFile' that only gives us the file name, and while
-- it will clean up the file afterwards, it's lenient if the file is
-- moved\/deleted.
@@ -170,7 +160,7 @@ withTempFileName
withTempFileName tmpDir template action =
Safe.bracket
(openTempFile tmpDir template)
- (\(name, _) -> removeExistingFile name)
+ (\(name, _) -> removeFileForcibly name)
(\(name, h) -> hClose h >> action name)
-- | Executes the action with an environment variable set to some
diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs
index d7fcbf4778d..1c36017c4f9 100644
--- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs
+++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs
@@ -81,8 +81,7 @@ instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where
remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo
remoteRepoGrammar name =
- RemoteRepo
- <$> pure name
+ pure (RemoteRepo name)
<*> uniqueFieldAla "url" URI_NT remoteRepoURILens
<*> optionalField "secure" remoteRepoSecureLens
<*> monoidalFieldAla "root-keys" (alaList' FSep Token) remoteRepoRootKeysLens
diff --git a/cabal-install/src/Distribution/Deprecated/ReadP.hs b/cabal-install/src/Distribution/Deprecated/ReadP.hs
index 69e1c38006e..b0c07ad4ea3 100644
--- a/cabal-install/src/Distribution/Deprecated/ReadP.hs
+++ b/cabal-install/src/Distribution/Deprecated/ReadP.hs
@@ -212,9 +212,7 @@ eof :: ReadP r ()
-- ^ Succeeds iff we are at the end of input
eof = do
s <- look
- if null s
- then return ()
- else pfail
+ unless (null s) pfail
(+++) :: ReadP r a -> ReadP r a -> ReadP r a
-- ^ Symmetric choice.
diff --git a/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs
index fb7ea8f91f6..4bd806c4f18 100644
--- a/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs
+++ b/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs
@@ -53,7 +53,7 @@ viewAsFieldDescr (OptionField n (d : dd)) = FieldDescr n get set
-- set :: LineNo -> String -> a -> ParseResult a
set line val a =
case optDescr of
- ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
+ ReqArg _ _ _ readE _ -> ($ a) <$> 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
@@ -62,8 +62,8 @@ viewAsFieldDescr (OptionField n (d : dd)) = FieldDescr n get set
case getChoiceByLongFlag optDescr val of
Just f -> return (f a)
_ -> syntaxError line val
- BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("" ++) parsec) val
- OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
+ BoolOpt _ _ _ setV _ -> (`setV` a) <$> runE line n (parsecToReadE ("" ++) parsec) val
+ OptArg _ _ _ readE _ _ -> ($ a) <$> runE line n readE val
-- Optional arguments are parsed just like
-- required arguments here; we don't
diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs
index f0fb930b1f9..0cef2e00b32 100644
--- a/cabal-install/tests/IntegrationTests2.hs
+++ b/cabal-install/tests/IntegrationTests2.hs
@@ -30,7 +30,7 @@ import Distribution.Client.TargetSelector hiding (DirActions (..))
import qualified Distribution.Client.TargetSelector as TS (DirActions (..))
import Distribution.Client.Targets
( UserConstraint (..)
- , UserConstraintScope (UserAnyQualifier)
+ , UserConstraintQualifier (UserAnyQualifier)
)
import Distribution.Client.Types
( PackageLocation (..)
@@ -66,7 +66,8 @@ import qualified Distribution.Simple.Flag as Flag
import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag)
import Distribution.System
import Distribution.Text
-import Distribution.Utils.Path (unsafeMakeSymbolicPath)
+import Distribution.Utils.LogProgress
+import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath)
import Distribution.Version
import Data.List (isInfixOf)
@@ -95,6 +96,7 @@ import System.IO.Silently
import qualified Data.ByteString as BS
import Distribution.Simple.Flag (pattern Flag)
+import Distribution.Simple.Utils (removeFileForcibly)
import Distribution.Types.ParStrat
import Distribution.Verbosity
@@ -114,7 +116,7 @@ main = do
defaultMainWithIngredients
(defaultIngredients ++ [includingOptions projectConfigOptionDescriptions])
( localOption (NumThreads 1) $ withProjectConfig $ \config ->
- sequentialTestGroup
+ dependentTestGroup
"Integration tests (internal)"
AllFinish
(tests config)
@@ -144,14 +146,14 @@ tests config =
-- TODO: tests for:
-- \* normal success
-- \* dry-run tests with changes
- [ sequentialTestGroup
+ [ dependentTestGroup
"Discovery and planning"
AllFinish
[ testCase "no package" (testExceptionInFindingPackage config)
, testCase "no package2" (testExceptionInFindingPackage2 config)
, testCase "proj conf1" (testExceptionInProjectConfig config)
]
- , sequentialTestGroup
+ , dependentTestGroup
"Target selectors"
AllFinish
[ testCaseSteps "valid" testTargetSelectors
@@ -170,7 +172,7 @@ tests config =
, testCaseSteps "problems (bench)" (testTargetProblemsBench config)
, testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config)
]
- , sequentialTestGroup
+ , dependentTestGroup
"Exceptions during building (local inplace)"
AllFinish
[ testCase "configure" (testExceptionInConfigureStep config)
@@ -181,14 +183,14 @@ tests config =
-- TODO: need to check we can build sub-libs, foreign libs and exes
-- components for non-local packages / packages in the store.
- sequentialTestGroup "Successful builds" AllFinish $
+ dependentTestGroup "Successful builds" AllFinish $
[ testCaseSteps "Setup script styles" (testSetupScriptStyles config)
, testCase "keep-going" (testBuildKeepGoing config)
]
++
-- disabled because https://github.com/haskell/cabal/issues/6272
[testCase "local tarball" (testBuildLocalTarball config) | System.Info.os /= "mingw32"]
- , sequentialTestGroup
+ , dependentTestGroup
"Regression tests"
AllFinish
[ testCase "issue #3324" (testRegressionIssue3324 config)
@@ -196,13 +198,13 @@ tests config =
, testCase "program options scope local" (testProgramOptionsLocal config)
, testCase "program options scope specific" (testProgramOptionsSpecific config)
]
- , sequentialTestGroup
+ , dependentTestGroup
"Flag tests"
AllFinish
[ testCase "Test Config options for commented options" testConfigOptionComments
, testCase "Test Ignore Project Flag" testIgnoreProjectFlag
]
- , sequentialTestGroup
+ , dependentTestGroup
"haddock-project"
AllFinish
[ testCase "dependencies" (testHaddockProjectDependencies config)
@@ -667,7 +669,7 @@ testTargetSelectorAmbiguous reportSubCase = do
, condSubLibraries = []
, condForeignLibs = []
, condExecutables =
- [ (exeName exe, CondNode exe [] [])
+ [ (exeName exe, CondNode exe [])
| exe <- exes
]
, condTestSuites = []
@@ -956,11 +958,11 @@ testTargetProblemsBuild config reportSubCase = do
CmdBuild.selectPackageTargets
CmdBuild.selectComponentTarget
[mkTargetPackage "p-0.1"]
- [ ("p-0.1-inplace", (CLibName LMainLibName))
- , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
- , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
- , ("p-0.1-inplace-an-exe", CExeName "an-exe")
- , ("p-0.1-inplace-libp", CFLibName "libp")
+ [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName))
+ , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
+ , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
+ , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe")
+ , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp")
]
reportSubCase "disabled component kinds"
@@ -982,9 +984,9 @@ testTargetProblemsBuild config reportSubCase = do
CmdBuild.selectPackageTargets
CmdBuild.selectComponentTarget
[mkTargetPackage "p-0.1"]
- [ ("p-0.1-inplace", (CLibName LMainLibName))
- , ("p-0.1-inplace-an-exe", CExeName "an-exe")
- , ("p-0.1-inplace-libp", CFLibName "libp")
+ [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName))
+ , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe")
+ , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp")
]
reportSubCase "requested component kinds"
@@ -999,8 +1001,8 @@ testTargetProblemsBuild config reportSubCase = do
[ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)
, TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)
]
- [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
- , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
+ [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
+ , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
]
testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion
@@ -1087,8 +1089,8 @@ testTargetProblemsRepl config reportSubCase = do
[ mkTargetComponent "p-0.1" (CExeName "p1")
, mkTargetComponent "p-0.1" (CExeName "p2")
]
- [ ("p-0.1-inplace-p1", CExeName "p1")
- , ("p-0.1-inplace-p2", CExeName "p2")
+ [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1")
+ , (WithStage Host "p-0.1-inplace-p2", CExeName "p2")
]
reportSubCase "libs-disabled"
@@ -1157,7 +1159,7 @@ testTargetProblemsRepl config reportSubCase = do
(CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False))
CmdRepl.selectComponentTarget
[TargetPackage TargetExplicitNamed ["p-0.1"] Nothing]
- [("p-0.1-inplace", (CLibName LMainLibName))]
+ [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))]
-- When we select the package with an explicit filter then we get those
-- components even though we did not explicitly enable tests/benchmarks
assertProjectDistinctTargets
@@ -1165,13 +1167,13 @@ testTargetProblemsRepl config reportSubCase = do
(CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False))
CmdRepl.selectComponentTarget
[TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)]
- [("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")]
+ [(WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")]
assertProjectDistinctTargets
elaboratedPlan
(CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False))
CmdRepl.selectComponentTarget
[TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)]
- [("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")]
+ [(WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")]
testTargetProblemsListBin :: ProjectConfig -> (String -> IO ()) -> Assertion
testTargetProblemsListBin config reportSubCase = do
@@ -1184,7 +1186,7 @@ testTargetProblemsListBin config reportSubCase = do
CmdListBin.selectComponentTarget
[ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing
]
- [ ("p-0.1-inplace-p1", CExeName "p1")
+ [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1")
]
reportSubCase "multiple-exes"
@@ -1221,8 +1223,8 @@ testTargetProblemsListBin config reportSubCase = do
[ mkTargetComponent "p-0.1" (CExeName "p1")
, mkTargetComponent "p-0.1" (CExeName "p2")
]
- [ ("p-0.1-inplace-p1", CExeName "p1")
- , ("p-0.1-inplace-p2", CExeName "p2")
+ [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1")
+ , (WithStage Host "p-0.1-inplace-p2", CExeName "p2")
]
reportSubCase "exes-disabled"
@@ -1269,7 +1271,7 @@ testTargetProblemsRun config reportSubCase = do
CmdRun.selectComponentTarget
[ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing
]
- [ ("p-0.1-inplace-p1", CExeName "p1")
+ [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1")
]
reportSubCase "multiple-exes"
@@ -1306,8 +1308,8 @@ testTargetProblemsRun config reportSubCase = do
[ mkTargetComponent "p-0.1" (CExeName "p1")
, mkTargetComponent "p-0.1" (CExeName "p2")
]
- [ ("p-0.1-inplace-p1", CExeName "p1")
- , ("p-0.1-inplace-p2", CExeName "p2")
+ [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1")
+ , (WithStage Host "p-0.1-inplace-p2", CExeName "p2")
]
reportSubCase "exes-disabled"
@@ -1710,11 +1712,11 @@ testTargetProblemsHaddock config reportSubCase = do
(CmdHaddock.selectPackageTargets haddockFlags)
CmdHaddock.selectComponentTarget
[mkTargetPackage "p-0.1"]
- [ ("p-0.1-inplace", (CLibName LMainLibName))
- , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
- , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
- , ("p-0.1-inplace-an-exe", CExeName "an-exe")
- , ("p-0.1-inplace-libp", CFLibName "libp")
+ [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName))
+ , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
+ , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
+ , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe")
+ , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp")
]
reportSubCase "disabled component kinds"
@@ -1726,7 +1728,7 @@ testTargetProblemsHaddock config reportSubCase = do
(CmdHaddock.selectPackageTargets haddockFlags)
CmdHaddock.selectComponentTarget
[mkTargetPackage "p-0.1"]
- [("p-0.1-inplace", (CLibName LMainLibName))]
+ [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))]
reportSubCase "requested component kinds"
-- When we selecting the package with an explicit filter then it does not
@@ -1741,10 +1743,10 @@ testTargetProblemsHaddock config reportSubCase = do
, TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)
, TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)
]
- [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
- , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
- , ("p-0.1-inplace-an-exe", CExeName "an-exe")
- , ("p-0.1-inplace-libp", CFLibName "libp")
+ [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")
+ , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")
+ , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe")
+ , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp")
]
where
mkHaddockFlags flib exe test bench =
@@ -1762,7 +1764,7 @@ assertProjectDistinctTargets
-> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k)
-> [TargetSelector]
- -> [(UnitId, ComponentName)]
+ -> [(WithStage UnitId, ComponentName)]
-> Assertion
assertProjectDistinctTargets
elaboratedPlan
@@ -1915,10 +1917,10 @@ testSetupScriptStyles config reportSubCase = do
let isOSX (Platform _ OSX) = True
isOSX _ = False
- compilerVer = compilerVersion (pkgConfigCompiler sharedConfig)
+ compilerVer = compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build)
-- Skip the Custom tests when the shipped Cabal library is buggy
unless
- ( (isOSX (pkgConfigPlatform sharedConfig) && (compilerVer < mkVersion [7, 10]))
+ ( (isOSX (toolchainPlatform $ getStage (pkgConfigToolchains sharedConfig) Build) && (compilerVer < mkVersion [7, 10]))
-- 9.10 ships Cabal 3.12.0.0 affected by #9940
|| (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11])
)
@@ -1929,10 +1931,10 @@ testSetupScriptStyles config reportSubCase = do
hasDefaultSetupDeps pkg1 @?= Just False
marker1 <- readFile (basedir testdir1 "marker")
marker1 @?= "ok"
- removeFile (basedir testdir1 "marker")
+ removeFileForcibly (basedir testdir1 "marker")
-- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later
- when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8, 2]) $ do
+ when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) < mkVersion [8, 2]) $ do
reportSubCase (show SetupCustomImplicitDeps)
(plan2, res2) <- executePlan =<< planProject testdir2 config
pkg2 <- expectPackageInstalled plan2 res2 pkgidA
@@ -1940,7 +1942,7 @@ testSetupScriptStyles config reportSubCase = do
hasDefaultSetupDeps pkg2 @?= Just True
marker2 <- readFile (basedir testdir2 "marker")
marker2 @?= "ok"
- removeFile (basedir testdir2 "marker")
+ removeFileForcibly (basedir testdir2 "marker")
reportSubCase (show SetupNonCustomInternalLib)
(plan3, res3) <- executePlan =<< planProject testdir3 config
@@ -2129,9 +2131,21 @@ getProgArgs :: [ElaboratedConfiguredPackage] -> String -> Maybe [String]
getProgArgs [] _ = Nothing
getProgArgs (elab : pkgs) name
| pkgName (elabPkgSourceId elab) == mkPackageName name =
- Map.lookup "ghc" (elabProgramArgs elab)
+ removeHideAllPackages $ Map.lookup "ghc" (elabProgramArgs elab)
| otherwise =
getProgArgs pkgs name
+ where
+ removeHideAllPackages mbArgs =
+ -- Filter out "-hide-all-packages", as we pass that by default
+ -- to GHC invocations in order to avoid it picking up environment files.
+ -- See https://github.com/haskell/cabal/issues/4010
+ case filter (/= "-hide-all-packages") <$> mbArgs of
+ Just args'
+ | null args' ->
+ Nothing
+ | otherwise ->
+ Just args'
+ Nothing -> Nothing
---------------------------------
-- Test utils to plan and build
@@ -2239,7 +2253,7 @@ executePlan
, elaboratedPlan
, elaboratedShared
) = do
- let targets :: Map.Map UnitId [ComponentTarget]
+ let targets :: Map.Map (WithStage UnitId) [ComponentTarget]
targets =
Map.fromList
[ (unitid, [ComponentTarget cname WholeComponent])
@@ -2250,10 +2264,12 @@ executePlan
ts
]
elaboratedPlan' =
- pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
+ either (error . show) id $
+ runLogProgress' $
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
pkgsBuildStatus <-
rebuildTargetsDryRun
@@ -2304,7 +2320,8 @@ mkProjectConfig (GhcPath ghcPath) =
mempty
{ projectConfigShared =
mempty
- { projectConfigHcPath = maybeToFlag ghcPath
+ { projectConfigToolchain =
+ mempty{projectConfigHcPath = maybeToFlag ghcPath}
}
, projectConfigBuildOnly =
mempty
@@ -2340,7 +2357,7 @@ expectPackagePreExisting
:: ElaboratedInstallPlan
-> BuildOutcomes
-> PackageId
- -> IO InstalledPackageInfo
+ -> IO (WithStage InstalledPackageInfo)
expectPackagePreExisting plan buildOutcomes pkgid = do
planpkg <- expectPlanPackage plan pkgid
case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of
@@ -2765,10 +2782,7 @@ testHaddockProjectDependencies config = do
(_, _, sharedConfig) <- planProject testdir config
-- `haddock-project` is only supported by `haddock-2.26.1` and above which is
-- shipped with `ghc-9.4`
- -- And doesn't work with older ghc on Windows for some reason (file in the
- -- wrong place, perhaps?).
- let safeMinor = if buildOS == Windows then 10 else 4
- when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, safeMinor]) $ do
+ when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) > mkVersion [9, 4]) $ do
let dir = basedir testdir
cleanHaddockProject testdir
withCurrentDirectory dir $ do
diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs
index 8434f623e82..0020c695d12 100644
--- a/cabal-install/tests/UnitTests.hs
+++ b/cabal-install/tests/UnitTests.hs
@@ -9,6 +9,7 @@ import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.Get
import qualified UnitTests.Distribution.Client.Glob
import qualified UnitTests.Distribution.Client.IndexUtils
+import qualified UnitTests.Distribution.Client.IndexUtils.ActiveRepos
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
import qualified UnitTests.Distribution.Client.Init
import qualified UnitTests.Distribution.Client.InstallPlan
@@ -52,6 +53,9 @@ main = do
, testGroup
"UnitTests.Distribution.Client.IndexUtils"
UnitTests.Distribution.Client.IndexUtils.tests
+ , testGroup
+ "UnitTests.Distribution.Client.IndexUtils.ActiveRepos"
+ UnitTests.Distribution.Client.IndexUtils.ActiveRepos.tests
, testGroup
"UnitTests.Distribution.Client.IndexUtils.Timestamp"
UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
index c8843761e69..18242903c12 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
@@ -44,6 +44,7 @@ import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalSt
import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
import Data.Coerce (Coercible, coerce)
+import Distribution.Solver.Types.Stage (Stage)
import Network.URI (URI (..), URIAuth (..), isUnreserved)
import Test.QuickCheck
( Arbitrary (..)
@@ -111,8 +112,7 @@ instance Arbitrary URI where
instance Arbitrary URIAuth where
arbitrary =
- URIAuth
- <$> pure "" -- no password as this does not roundtrip
+ pure (URIAuth "") -- no password as this does not roundtrip
<*> arbitraryURIToken
<*> arbitraryURIPort
@@ -287,6 +287,10 @@ instance Arbitrary UserConstraintScope where
arbitrary = genericArbitrary
shrink = genericShrink
+instance Arbitrary UserConstraintQualifier where
+ arbitrary = genericArbitrary
+ shrink = genericShrink
+
instance Arbitrary UserQualifier where
arbitrary =
oneof
@@ -324,6 +328,10 @@ instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where
TestStanzas -> x1
BenchStanzas -> x2
+instance Arbitrary Stage where
+ arbitrary = genericArbitrary
+ shrink = genericShrink
+
-------------------------------------------------------------------------------
-- BuildReport
-------------------------------------------------------------------------------
@@ -387,9 +395,8 @@ instance Arbitrary Glob where
take
(max 1 sz)
[ pure GlobDirTrailing
- , GlobFile <$> (getGlobPieces <$> arbitrary)
- , GlobDir
- <$> (getGlobPieces <$> arbitrary)
+ , GlobFile . getGlobPieces <$> arbitrary
+ , (GlobDir . getGlobPieces <$> arbitrary)
<*> resize (sz `div` 2) arbitrary
]
@@ -421,6 +428,11 @@ instance Arbitrary GlobPieces where
mergeLiterals :: [GlobPiece] -> [GlobPiece]
mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps)
mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps
+-- Two consecutive wildcards are semantically equivalent to a single one, but
+-- would syntactically produce a recursive wildcard when pretty-printed, so
+-- whenever we end up generating two or more consecutive wildcards, we merge
+-- them together to avoid this problem.
+mergeLiterals (WildCard : WildCard : ps) = mergeLiterals (WildCard : ps)
mergeLiterals (p : ps) = p : mergeLiterals ps
mergeLiterals [] = []
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs b/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs
index a5ec944369e..21a6bcabb46 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs
@@ -4,7 +4,6 @@ module UnitTests.Distribution.Client.Configure (tests) where
import Distribution.Client.CmdConfigure
-import Control.Monad
import qualified Data.Map as Map
import Distribution.Client.NixStyleOptions
import Distribution.Client.ProjectConfig.Types
@@ -12,6 +11,7 @@ import Distribution.Client.ProjectFlags
import Distribution.Client.Setup
import Distribution.Simple
import Distribution.Simple.Flag
+import Distribution.Simple.Utils (removeFileForcibly)
import Distribution.Verbosity
import System.Directory
import System.FilePath
@@ -109,9 +109,7 @@ configureTests =
}
backup = projectDir "cabal.project.local~"
- exists <- doesFileExist backup
- when exists $
- removeFile backup
+ removeFileForcibly backup
_ <- configureAction' flags [] defaultGlobalFlags
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
index f359e224dd8..5ce53aa06aa 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
@@ -13,7 +13,7 @@ import Prelude hiding (writeFile)
import qualified Prelude as IO (writeFile)
import Distribution.Compat.Binary
-import Distribution.Simple.Utils (withTempDirectory)
+import Distribution.Simple.Utils (removeFileForcibly, withTempDirectory)
import Distribution.System (OS (Windows), buildOS)
import Distribution.Client.FileMonitor
@@ -53,11 +53,21 @@ tests mtimeChange =
, testCase "remove match" $ testGlobRemoveMatch mtimeChange
, testCase "change match" $ testGlobChangeMatch mtimeChange
, testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange
+ , testCase "add match subdir, recursive glob" $ testRecursiveGlobAddMatchSubdir mtimeChange
+ , testCase "add match sub-subdir, recursive glob" $ testRecursiveGlobAddMatchSubSubdir mtimeChange
+ , testCase "add match new sub-subdir, recursive glob" $ testRecursiveGlobAddMatchNewSubSubdir mtimeChange
+ , testCase "add match new deep sub-subdir, recursive glob" $ testRecursiveGlobAddMatchNewDeepSubSubdir mtimeChange
+ , testCase "move subdir, recursive glob" $ testRecursiveGlobMoveSubdir mtimeChange
+ , testCase "move matching dir, recursive glob" $ testRecursiveGlobMoveMatchingDir mtimeChange
, testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange
+ , testCase "remove match subdir, recursive glob" $ testRecursiveGlobRemoveMatchSubdir mtimeChange
+ , testCase "remove match sub-subdir, recursive glob" $ testRecursiveGlobRemoveMatchSubSubdir mtimeChange
, testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange
+ , testCase "change match subdir, recursive glob" $ testRecursiveGlobChangeMatchSubdir mtimeChange
, testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange
, testCase "add non-match" $ testGlobAddNonMatch mtimeChange
, testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange
+ , testCase "remove non-match, recursive glob" $ testRecursiveGlobRemoveNonMatch mtimeChange
, knownBrokenInWindows "See issue #3126" $
testCase "add non-match subdir" $
testGlobAddNonMatchSubdir mtimeChange
@@ -85,10 +95,10 @@ tests mtimeChange =
Windows -> expectFailBecause msg
_ -> id
fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64
- fingerprintStateGlob1 = 0x1f9edda22b7e8de6
- fingerprintStateGlob2 = 0xda1d085c9fc6f5db
- fingerprintStateFileSet1 = 0x00ac4a0df546905d
- fingerprintStateFileSet2 = 0x5b2b2df018b1fa83
+ fingerprintStateGlob1 = 0x5d9efec2b93d22a1
+ fingerprintStateGlob2 = 0xfdbc86351866a191
+ fingerprintStateFileSet1 = 0x4cee0a3a23697bb1
+ fingerprintStateFileSet2 = 0x96039d15c3241985
-- Check the file system behaves the way we expect it to
@@ -516,6 +526,69 @@ testGlobAddMatchSubdir mtimeChange =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" "b" "good-b")
+testRecursiveGlobAddMatchSubdir :: Int -> Assertion
+testRecursiveGlobAddMatchSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "good-a")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ touchFile root ("dir" "b" "good-b")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "b" "good-b")
+
+testRecursiveGlobAddMatchSubSubdir :: Int -> Assertion
+testRecursiveGlobAddMatchSubSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "good-a")
+ touchFile root ("dir" "a" "b" "good-b")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ touchFile root ("dir" "a" "b" "good-c")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "a" "b" "good-c")
+
+testRecursiveGlobAddMatchNewSubSubdir :: Int -> Assertion
+testRecursiveGlobAddMatchNewSubSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "good-a")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ touchFile root ("dir" "a" "b" "good-b")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "a" "b" "good-b")
+
+testRecursiveGlobAddMatchNewDeepSubSubdir :: Int -> Assertion
+testRecursiveGlobAddMatchNewDeepSubSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "b" "good-a")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ touchFile root ("dir" "b" "c" "good-b")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "b" "c" "good-b")
+
+testRecursiveGlobMoveSubdir :: Int -> Assertion
+testRecursiveGlobMoveSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "b" "good-a")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ touchFile root ("dir" "b" "b" "good-a")
+ removeFile root ("dir" "a" "b" "good-a")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "a" "b" "good-a")
+
+testRecursiveGlobMoveMatchingDir :: Int -> Assertion
+testRecursiveGlobMoveMatchingDir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "good-a")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ removeDir root "dir"
+ touchFile root ("dir2" "a" "good-a")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "a" "good-a")
+
testGlobRemoveMatchSubdir :: Int -> Assertion
testGlobRemoveMatchSubdir mtimeChange =
withFileMonitor $ \root monitor -> do
@@ -527,6 +600,28 @@ testGlobRemoveMatchSubdir mtimeChange =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" "a" "good-a")
+testRecursiveGlobRemoveMatchSubdir :: Int -> Assertion
+testRecursiveGlobRemoveMatchSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "a" "good-a")
+ touchFile root ("dir" "b" "b" "good-b")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ removeDir root ("dir" "a")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "a" "a" "good-a")
+
+testRecursiveGlobRemoveMatchSubSubdir :: Int -> Assertion
+testRecursiveGlobRemoveMatchSubSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "a" "good-a")
+ touchFile root ("dir" "a" "b" "good-b")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ removeDir root ("dir" "a" "a")
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "a" "a" "good-a")
+
testGlobChangeMatchSubdir :: Int -> Assertion
testGlobChangeMatchSubdir mtimeChange =
withFileMonitor $ \root monitor -> do
@@ -543,6 +638,22 @@ testGlobChangeMatchSubdir mtimeChange =
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" "b" "good-b")
+testRecursiveGlobChangeMatchSubdir :: Int -> Assertion
+testRecursiveGlobChangeMatchSubdir mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "c" "good-a")
+ touchFile root ("dir" "b" "c" "good-b")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ touchFile root ("dir" "b" "c" "good-b")
+ (res, files) <- expectMonitorUnchanged root monitor ()
+ res @?= ()
+ files @?= [monitorFileGlobStr "dir/**/good-*"]
+
+ touchFileContent root "dir/b/c/good-b"
+ reason <- expectMonitorChanged root monitor ()
+ reason @?= MonitoredFileChanged ("dir" "b" "c" "good-b")
+
-- check nothing goes squiffy with matching in the top dir
testGlobMatchTopDir :: Int -> Assertion
testGlobMatchTopDir mtimeChange =
@@ -576,6 +687,18 @@ testGlobRemoveNonMatch mtimeChange =
res @?= ()
files @?= [monitorFileGlobStr "dir/good-*"]
+testRecursiveGlobRemoveNonMatch :: Int -> Assertion
+testRecursiveGlobRemoveNonMatch mtimeChange =
+ withFileMonitor $ \root monitor -> do
+ touchFile root ("dir" "a" "good-a")
+ touchFile root ("dir" "b" "bad")
+ updateMonitor root monitor [monitorFileGlobStr "dir/**/good-*"] () ()
+ threadDelay mtimeChange
+ removeFile root "dir/b/bad"
+ (res, files) <- expectMonitorUnchanged root monitor ()
+ res @?= ()
+ files @?= [monitorFileGlobStr "dir/**/good-*"]
+
testGlobAddNonMatchSubdir :: Int -> Assertion
testGlobAddNonMatchSubdir mtimeChange =
withFileMonitor $ \root monitor -> do
@@ -818,7 +941,7 @@ touchFileContent (RootPath root) fname = do
IO.writeFile path "different"
removeFile :: RootPath -> FilePath -> IO ()
-removeFile (RootPath root) fname = IO.removeFile (root fname)
+removeFile (RootPath root) fname = removeFileForcibly (root fname)
touchDir :: RootPath -> FilePath -> IO ()
touchDir root@(RootPath rootdir) dname = do
@@ -905,5 +1028,4 @@ withFileMonitor action = do
let file = root <.> "monitor"
monitor = newFileMonitor file
finally (action (RootPath root) monitor) $ do
- exists <- IO.doesFileExist file
- when exists $ IO.removeFile file
+ removeFileForcibly file
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs
index 1ba189fe16a..3680ffdbf7e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs
@@ -11,6 +11,7 @@ import Control.Exception (try)
import Data.ByteString as BS (null)
import Data.ByteString.Lazy as BSL (pack, toChunks)
import Data.ByteString.Lazy.Char8 as BSLL (init, length, pack)
+import Data.Either (isLeft)
import Distribution.Client.GZipUtils (maybeDecompress)
import Test.Tasty
@@ -55,8 +56,3 @@ prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === ori
where
original = BSL.pack ws
compressedGZip = GZip.compress original
-
--- (Only available from "Data.Either" since 7.8.)
-isLeft :: Either a b -> Bool
-isLeft (Right _) = False
-isLeft (Left _) = True
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
index 2ca174e5d34..2f01b684f0e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
@@ -262,7 +262,7 @@ assertException action = do
Right _ ->
assertFailure $
"expected exception of type "
- ++ show (typeOf (undefined :: e))
+ ++ show (typeRep (Proxy :: Proxy e))
-- | Expect that one line in a file matches exactly the given words (i.e. at
-- least insensitive to whitespace)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
index b41a4dd3fc3..eb7a4feae0c 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
@@ -46,6 +46,19 @@ testParseCases = do
RootedGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
RootedGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
+ RootedGlob
+ FilePathRelative
+ (GlobDirRecursive [WildCard]) <-
+ testparse "**/*"
+ RootedGlob
+ FilePathRelative
+ (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard])) <-
+ testparse "foo/**/*"
+ RootedGlob
+ FilePathRelative
+ (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard, Literal ".txt"])) <-
+ testparse "foo/**/*.txt"
+
RootedGlob
FilePathRelative
(GlobFile [Literal "."]) <-
@@ -106,7 +119,7 @@ testParseCases = do
RootedGlob
FilePathRelative
(GlobFile [WildCard, WildCard]) <-
- testparse "**" -- not helpful but valid
+ testparse "**" -- not helpful, but valid (?)
RootedGlob
FilePathRelative
(GlobFile [WildCard, Literal "foo", WildCard]) <-
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs
index fbd5952019a..a4a69870588 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs
@@ -1,21 +1,29 @@
module UnitTests.Distribution.Client.IndexUtils where
import Distribution.Client.IndexUtils
+import Distribution.Client.IndexUtils.ActiveRepos
import qualified Distribution.Compat.NonEmptySet as NES
+import Distribution.Package
import Distribution.Simple.Utils (toUTF8LBS)
-import Distribution.Types.Dependency
+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import Distribution.Types.LibraryName
-import Distribution.Types.PackageName
import Distribution.Version
+import qualified Data.List as List
+
import Test.Tasty
import Test.Tasty.HUnit
tests :: [TestTree]
tests =
[ simpleVersionsParserTests
+ , indexCombiningTests
]
+-- ---------------------------------------------------------------------------
+-- Preferred-versions parser tests
+-- ---------------------------------------------------------------------------
+
simpleVersionsParserTests :: TestTree
simpleVersionsParserTests =
testGroup
@@ -80,3 +88,108 @@ simpleVersionsParserTests =
]
, preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0"
}
+
+-- ---------------------------------------------------------------------------
+-- Index-combining tests
+--
+-- These test 'applyStrategy' (exported from IndexUtils), which is the
+-- per-repository step used by getSourcePackagesAtIndexState:
+--
+-- applyStrategy acc (_, Skip) = acc
+-- applyStrategy acc (idx, Merge) = PackageIndex.merge acc idx
+-- applyStrategy acc (idx, Override) = PackageIndex.override acc idx
+-- pkgs = foldl' (\acc (rd, s) -> applyStrategy acc (rdIndex rd, s)) mempty pkgss'
+-- ---------------------------------------------------------------------------
+
+indexCombiningTests :: TestTree
+indexCombiningTests =
+ testGroup
+ "Index combining (CombineStrategy)"
+ [ testCase "Skip: repo contributes nothing" $
+ pkgs [(repoFoo1, CombineStrategySkip)]
+ @?= []
+ , testCase "Merge: single repo makes all its packages visible" $
+ pkgs [(repoFoo1, CombineStrategyMerge)]
+ @?= [foo1]
+ , testCase "Override: single repo makes all its packages visible" $
+ pkgs [(repoFoo1, CombineStrategyOverride)]
+ @?= [foo1]
+ , testCase "Merge+Merge: non-overlapping packages are both visible" $
+ pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyMerge)]
+ @?= List.sort [foo1, bar1]
+ , testCase "Merge+Merge: different versions of same package are both visible" $
+ pkgs [(repoFoo1, CombineStrategyMerge), (repoFoo2, CombineStrategyMerge)]
+ @?= List.sort [foo1, foo2]
+ , testCase "Merge+Override: packages only in first repo remain visible" $
+ pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyOverride)]
+ @?= List.sort [foo1, bar1]
+ , testCase "Merge+Override: override repo replaces all versions of overlapping package" $
+ -- repoFoo12 has foo-1.0 and foo-2.0; repoFoo2 has only foo-2.0.
+ -- Override means repoFoo2 wins the entire 'foo' bucket.
+ pkgs [(repoFoo12, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)]
+ @?= [foo2]
+ , testCase "Merge+Override: override does not affect packages absent from override repo" $
+ pkgs [(repoFoo1bar1, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)]
+ @?= List.sort [foo2, bar1]
+ , testCase "Skip in middle: skipped repo is ignored" $
+ pkgs
+ [ (repoFoo1, CombineStrategyMerge)
+ , (repoFoo2, CombineStrategySkip)
+ , (repoBar1, CombineStrategyMerge)
+ ]
+ @?= List.sort [foo1, bar1]
+ , testCase "Skip+Merge: later merge after skip still contributes" $
+ pkgs [(repoFoo1, CombineStrategySkip), (repoFoo2, CombineStrategyMerge)]
+ @?= [foo2]
+ , testCase "Override+Override: last override wins the package bucket" $
+ pkgs
+ [ (repoFoo1, CombineStrategyMerge)
+ , (repoFoo2, CombineStrategyOverride)
+ , (repoFoo3, CombineStrategyOverride)
+ ]
+ @?= [foo3]
+ , testCase "Override+Merge: merge after override combines both buckets" $
+ -- foo bucket starts as {foo-2.0} after override, then merges {foo-3.0}
+ -- giving {foo-2.0, foo-3.0}
+ pkgs
+ [ (repoFoo1, CombineStrategyMerge)
+ , (repoFoo2, CombineStrategyOverride)
+ , (repoFoo3, CombineStrategyMerge)
+ ]
+ @?= List.sort [foo2, foo3]
+ , testCase "All skip: result is empty" $
+ pkgs
+ [ (repoFoo1, CombineStrategySkip)
+ , (repoFoo2, CombineStrategySkip)
+ ]
+ @?= []
+ , testCase "Empty repos list: result is empty" $
+ pkgs [] @?= []
+ ]
+
+-- Run the combining fold and return the result as a sorted list of PackageIds.
+-- Uses the exported 'applyStrategy' from IndexUtils directly, so this stays
+-- in sync with the production implementation in getSourcePackagesAtIndexState.
+pkgs
+ :: [(PackageIndex.PackageIndex PackageIdentifier, CombineStrategy)]
+ -> [PackageIdentifier]
+pkgs = List.sort . PackageIndex.allPackages . List.foldl' applyStrategy mempty
+
+-- Test packages
+foo1, foo2, foo3, bar1 :: PackageIdentifier
+foo1 = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0])
+foo2 = PackageIdentifier (mkPackageName "foo") (mkVersion [2, 0])
+foo3 = PackageIdentifier (mkPackageName "foo") (mkVersion [3, 0])
+bar1 = PackageIdentifier (mkPackageName "bar") (mkVersion [1, 0])
+
+-- Single-package indices
+repoFoo1, repoFoo2, repoFoo3, repoBar1 :: PackageIndex.PackageIndex PackageIdentifier
+repoFoo1 = PackageIndex.fromList [foo1]
+repoFoo2 = PackageIndex.fromList [foo2]
+repoFoo3 = PackageIndex.fromList [foo3]
+repoBar1 = PackageIndex.fromList [bar1]
+
+-- Multi-package indices
+repoFoo12, repoFoo1bar1 :: PackageIndex.PackageIndex PackageIdentifier
+repoFoo12 = PackageIndex.fromList [foo1, foo2]
+repoFoo1bar1 = PackageIndex.fromList [foo1, bar1]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs
new file mode 100644
index 00000000000..b33da1eaadf
--- /dev/null
+++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs
@@ -0,0 +1,169 @@
+module UnitTests.Distribution.Client.IndexUtils.ActiveRepos (tests) where
+
+import Distribution.Client.IndexUtils.ActiveRepos
+import Distribution.Client.Types.RepoName (RepoName (..))
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty (prettyShow)
+
+import UnitTests.Distribution.Client.ArbitraryInstances ()
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+
+tests :: [TestTree]
+tests =
+ [ testGroup "organizeByRepos" organizeByReposTests
+ , testGroup "filterSkippedActiveRepos" filterSkippedTests
+ , testGroup
+ "parse/pretty roundtrip"
+ [ testProperty "ActiveRepos roundtrips" prop_activeReposRoundtrip
+ ]
+ ]
+
+-------------------------------------------------------------------------------
+-- organizeByRepos
+-------------------------------------------------------------------------------
+
+-- Convenience: run organizeByRepos over a fixed three-element repo list.
+organize :: ActiveRepos -> Either String [(RepoName, CombineStrategy)]
+organize ar = organizeByRepos ar id [RepoName "a", RepoName "b", RepoName "c"]
+
+organizeByReposTests :: [TestTree]
+organizeByReposTests =
+ [ testCase ":rest assigns strategy to all repos in order" $
+ organize (ActiveRepos [ActiveRepoRest CombineStrategyMerge])
+ @?= Right
+ [ (RepoName "a", CombineStrategyMerge)
+ , (RepoName "b", CombineStrategyMerge)
+ , (RepoName "c", CombineStrategyMerge)
+ ]
+ , testCase ":none yields empty result" $
+ organize (ActiveRepos [])
+ @?= Right []
+ , testCase "named repo before :rest is placed first" $
+ organize
+ ( ActiveRepos
+ [ ActiveRepo (RepoName "b") CombineStrategyOverride
+ , ActiveRepoRest CombineStrategyMerge
+ ]
+ )
+ @?= Right
+ [ (RepoName "b", CombineStrategyOverride)
+ , (RepoName "a", CombineStrategyMerge)
+ , (RepoName "c", CombineStrategyMerge)
+ ]
+ , testCase "named repo after :rest is placed last" $
+ organize
+ ( ActiveRepos
+ [ ActiveRepoRest CombineStrategyMerge
+ , ActiveRepo (RepoName "b") CombineStrategyOverride
+ ]
+ )
+ @?= Right
+ [ (RepoName "a", CombineStrategyMerge)
+ , (RepoName "c", CombineStrategyMerge)
+ , (RepoName "b", CombineStrategyOverride)
+ ]
+ , testCase "named repo absent from provided list gives Left" $
+ organize
+ ( ActiveRepos
+ [ ActiveRepoRest CombineStrategyMerge
+ , ActiveRepo (RepoName "d") CombineStrategyOverride
+ ]
+ )
+ @?= Left "no repository provided d"
+ , testCase "named repo against empty list gives Left" $
+ organizeByRepos
+ (ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge])
+ id
+ ([] :: [RepoName])
+ @?= Left "no repository provided a"
+ , testCase "skip strategy is preserved in output" $
+ organize
+ ( ActiveRepos
+ [ ActiveRepo (RepoName "a") CombineStrategySkip
+ , ActiveRepoRest CombineStrategyMerge
+ ]
+ )
+ @?= Right
+ [ (RepoName "a", CombineStrategySkip)
+ , (RepoName "b", CombineStrategyMerge)
+ , (RepoName "c", CombineStrategyMerge)
+ ]
+ , testCase ":rest with skip strategy skips all remaining repos" $
+ organize (ActiveRepos [ActiveRepoRest CombineStrategySkip])
+ @?= Right
+ [ (RepoName "a", CombineStrategySkip)
+ , (RepoName "b", CombineStrategySkip)
+ , (RepoName "c", CombineStrategySkip)
+ ]
+ , testCase "multiple :rest entries cause each repo to appear once per :rest" $
+ -- Documented edge case: if ActiveRepoRest appears more than once,
+ -- the rest-repositories appear multiple times in the output.
+ organize
+ ( ActiveRepos
+ [ ActiveRepoRest CombineStrategyMerge
+ , ActiveRepoRest CombineStrategyOverride
+ ]
+ )
+ @?= Right
+ [ (RepoName "a", CombineStrategyMerge)
+ , (RepoName "b", CombineStrategyMerge)
+ , (RepoName "c", CombineStrategyMerge)
+ , (RepoName "a", CombineStrategyOverride)
+ , (RepoName "b", CombineStrategyOverride)
+ , (RepoName "c", CombineStrategyOverride)
+ ]
+ ]
+
+-------------------------------------------------------------------------------
+-- filterSkippedActiveRepos
+-------------------------------------------------------------------------------
+
+filterSkippedTests :: [TestTree]
+filterSkippedTests =
+ [ testCase "skipped entries are removed when no :rest is present" $
+ filterSkippedActiveRepos
+ ( ActiveRepos
+ [ ActiveRepo (RepoName "a") CombineStrategyMerge
+ , ActiveRepo (RepoName "b") CombineStrategySkip
+ ]
+ )
+ @?= ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge]
+ , testCase "all-skipped list with no :rest yields empty" $
+ filterSkippedActiveRepos
+ ( ActiveRepos
+ [ ActiveRepo (RepoName "a") CombineStrategySkip
+ , ActiveRepo (RepoName "b") CombineStrategySkip
+ ]
+ )
+ @?= ActiveRepos []
+ , testCase "list without any skipped entries is unchanged" $
+ let ar =
+ ActiveRepos
+ [ ActiveRepo (RepoName "a") CombineStrategyMerge
+ , ActiveRepo (RepoName "b") CombineStrategyOverride
+ ]
+ in filterSkippedActiveRepos ar @?= ar
+ , testCase "skipped entries are kept when :rest is present" $
+ -- filterSkippedActiveRepos is a no-op when ActiveRepoRest appears
+ let ar =
+ ActiveRepos
+ [ ActiveRepoRest CombineStrategyMerge
+ , ActiveRepo (RepoName "b") CombineStrategySkip
+ ]
+ in filterSkippedActiveRepos ar @?= ar
+ , testCase ":rest with skip strategy is kept unchanged" $
+ let ar = ActiveRepos [ActiveRepoRest CombineStrategySkip]
+ in filterSkippedActiveRepos ar @?= ar
+ ]
+
+-------------------------------------------------------------------------------
+-- Parse/pretty roundtrip
+-------------------------------------------------------------------------------
+
+prop_activeReposRoundtrip :: ActiveRepos -> Property
+prop_activeReposRoundtrip ar =
+ counterexample ("prettyShow: " ++ prettyShow ar) $
+ simpleParsec (prettyShow ar) === Just ar
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs
index 79bd67ea7d1..e03fb1a50df 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs
@@ -41,7 +41,7 @@ tests = do
, NonInteractive.tests v initFlags' comp pkgIx srcDb
, Golden.tests v initFlags' pkgIx srcDb
, Simple.tests v initFlags' pkgIx srcDb
- , FileCreators.tests v initFlags' comp pkgIx srcDb
+ , FileCreators.tests v initFlags' pkgIx srcDb
]
where
v :: Verbosity
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs
index da2c1e8d487..4f3757e174a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs
@@ -14,7 +14,6 @@ import Distribution.Client.Init.FileCreators
import Distribution.Client.Init.NonInteractive.Command
import Distribution.Client.Init.Types
import Distribution.Client.Types
-import Distribution.Simple
import Distribution.Simple.Flag
import Distribution.Simple.PackageIndex
import Distribution.Verbosity
@@ -22,11 +21,10 @@ import Distribution.Verbosity
tests
:: Verbosity
-> InitFlags
- -> Compiler
-> InstalledPackageIndex
-> SourcePackageDb
-> TestTree
-tests _v _initFlags comp pkgIx srcDb =
+tests _v _initFlags pkgIx srcDb =
testGroup
"Distribution.Client.Init.FileCreators"
[ testCase "Check . as source directory" $ do
@@ -82,7 +80,7 @@ tests _v _initFlags comp pkgIx srcDb =
]
case flip runPrompt inputs $ do
- projSettings <- createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags'
+ projSettings <- createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags'
writeProject projSettings of
Left (BreakException ex) -> assertFailure $ show ex
Right _ -> return ()
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
index 6e3c096467b..4f328a4c8af 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
@@ -44,11 +44,11 @@ tests _v _initFlags comp pkgIx srcDb =
"Distribution.Client.Init.NonInteractive.Command"
[ testGroup
"driver function test"
- [ driverFunctionTest pkgIx srcDb comp
+ [ driverFunctionTest pkgIx srcDb
]
, testGroup
"target creator tests"
- [ fileCreatorTests pkgIx srcDb comp
+ [ fileCreatorTests pkgIx srcDb
]
, testGroup
"non-interactive tests"
@@ -63,9 +63,8 @@ tests _v _initFlags comp pkgIx srcDb =
driverFunctionTest
:: InstalledPackageIndex
-> SourcePackageDb
- -> Compiler
-> TestTree
-driverFunctionTest pkgIx srcDb comp =
+driverFunctionTest pkgIx srcDb =
testGroup
"createProject"
[ testGroup
@@ -93,7 +92,7 @@ driverFunctionTest pkgIx srcDb comp =
, "[\"quxTest/Main.hs\"]"
]
- case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of
+ case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of
Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
_optOverwrite opts @?= False
_optMinimal opts @?= False
@@ -180,7 +179,7 @@ driverFunctionTest pkgIx srcDb comp =
"False"
]
- case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of
+ case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of
Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
_optOverwrite opts @?= False
_optMinimal opts @?= False
@@ -358,7 +357,6 @@ driverFunctionTest pkgIx srcDb comp =
case ( runPrompt $
createProject
- comp
(mkVerbosity defaultVerbosityHandles silent)
pkgIx
srcDb
@@ -510,7 +508,6 @@ driverFunctionTest pkgIx srcDb comp =
case ( runPrompt $
createProject
- comp
(mkVerbosity defaultVerbosityHandles silent)
pkgIx
srcDb
@@ -664,7 +661,7 @@ driverFunctionTest pkgIx srcDb comp =
, "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
]
- case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of
+ case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of
Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do
_optOverwrite opts @?= False
_optMinimal opts @?= False
@@ -774,7 +771,7 @@ driverFunctionTest pkgIx srcDb comp =
, "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
]
- case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of
+ case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of
Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
_optOverwrite opts @?= False
_optMinimal opts @?= False
@@ -865,7 +862,7 @@ driverFunctionTest pkgIx srcDb comp =
, "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
]
- case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of
+ case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of
Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do
_optOverwrite opts @?= False
_optMinimal opts @?= False
@@ -905,9 +902,8 @@ driverFunctionTest pkgIx srcDb comp =
fileCreatorTests
:: InstalledPackageIndex
-> SourcePackageDb
- -> Compiler
-> TestTree
-fileCreatorTests pkgIx srcDb comp =
+fileCreatorTests pkgIx srcDb =
testGroup
"generators"
[ testGroup
@@ -980,7 +976,7 @@ fileCreatorTests pkgIx srcDb comp =
, "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
]
- case (runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of
+ case (runPrompt $ genLibTarget emptyFlags pkgIx defaultCabalVersion) inputs of
Left e -> assertFailure $ show e
Right{} -> return ()
]
@@ -1021,7 +1017,7 @@ fileCreatorTests pkgIx srcDb comp =
, "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
]
- case (runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of
+ case (runPrompt $ genExeTarget emptyFlags pkgIx defaultCabalVersion) inputs of
Left e -> assertFailure $ show e
Right{} -> return ()
]
@@ -1058,7 +1054,7 @@ fileCreatorTests pkgIx srcDb comp =
]
flags = emptyFlags{initializeTestSuite = Flag True}
- case (runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of
+ case (runPrompt $ genTestTarget flags pkgIx defaultCabalVersion) inputs of
Left e -> assertFailure $ show e
Right{} -> return ()
]
@@ -1167,24 +1163,6 @@ nonInteractiveTests pkgIx srcDb comp =
CabalSpecV2_4
["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"]
]
- , testGroup
- "Check languageHeuristics output"
- [ testSimple
- "Non GHC compiler"
- (`languageHeuristics` (comp{compilerId = CompilerId Helium $ mkVersion [1, 8, 1]}))
- Haskell2010
- []
- , testSimple
- "Higher version compiler"
- (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [8, 10, 4]}))
- Haskell2010
- []
- , testSimple
- "Lower version compiler"
- (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [6, 0, 1]}))
- Haskell98
- []
- ]
, testGroup
"Check extraDocFileHeuristics output"
[ testSimple
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
index 9db7109fbc6..b3b2c4bd794 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
@@ -1,4 +1,7 @@
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
@@ -6,7 +9,7 @@ module UnitTests.Distribution.Client.InstallPlan (tests) where
import Distribution.Client.Compat.Prelude
-import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)
+import Distribution.Client.InstallPlan (GenericInstallPlan)
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.JobControl
import Distribution.Client.Types
@@ -29,6 +32,7 @@ import qualified Data.Set as Set
import System.Random
import Test.QuickCheck
+import Distribution.Utils.LogProgress
import Test.Tasty
import Test.Tasty.QuickCheck
@@ -136,7 +140,7 @@ isReversePartialTopologicalOrder g vs =
| let ixs =
array
(bounds g)
- ( zip (range (bounds g)) (repeat Nothing)
+ ( map (,Nothing) (range (bounds g))
++ zip vs (map Just [0 :: Int ..])
)
, (u, v) <- edges g
@@ -224,8 +228,13 @@ arbitraryTestInstallPlan = do
-- It takes generators for installed and source packages and the chance that
-- each package is installed (for those packages with no prerequisites).
arbitraryInstallPlan
- :: ( IsUnit ipkg
- , IsUnit srcpkg
+ :: forall ipkg srcpkg key
+ . ( IsNode ipkg
+ , Key ipkg ~ key
+ , IsNode srcpkg
+ , Key srcpkg ~ key
+ , Show key
+ , Pretty key
)
=> (Vertex -> [Vertex] -> Gen ipkg)
-> (Vertex -> [Vertex] -> Gen srcpkg)
@@ -249,24 +258,28 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do
, let isRoot = n == 0
]
- ipkgs <-
- sequenceA
- [ mkIPkg pkgv depvs
- | pkgv <- ipkgvs
- , let depvs = graph ! pkgv
- ]
- srcpkgs <-
- sequenceA
- [ mkSrcPkg pkgv depvs
- | pkgv <- srcpkgvs
- , let depvs = graph ! pkgv
- ]
- let index =
- Graph.fromDistinctList
- ( map InstallPlan.PreExisting ipkgs
- ++ map InstallPlan.Configured srcpkgs
- )
- return $ InstallPlan.new (IndependentGoals False) index
+ let gen_plan :: Gen (Either ErrMsg (InstallPlan.GenericInstallPlan ipkg srcpkg))
+ gen_plan = do
+ ipkgs <-
+ sequenceA
+ [ mkIPkg pkgv depvs
+ | pkgv <- ipkgvs
+ , let depvs = graph ! pkgv
+ ]
+ srcpkgs <-
+ sequenceA
+ [ mkSrcPkg pkgv depvs
+ | pkgv <- srcpkgvs
+ , let depvs = graph ! pkgv
+ ]
+ let index =
+ Graph.fromDistinctList
+ ( map InstallPlan.PreExisting ipkgs
+ ++ map InstallPlan.Configured srcpkgs
+ )
+ return $ runLogProgress' $ InstallPlan.new' index
+
+ gen_plan `suchThatMap` either (const Nothing) Just
-- | Generate a random directed acyclic graph, based on the algorithm presented
-- here
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
index ea286554201..6a68d366507 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -27,7 +27,6 @@ import System.IO.Unsafe (unsafePerformIO)
import Distribution.Deprecated.ParseUtils
import qualified Distribution.Deprecated.ReadP as Parse
-import Distribution.Compiler
import Distribution.Package
import Distribution.PackageDescription
import qualified Distribution.Simple.InstallDirs as InstallDirs
@@ -36,7 +35,6 @@ import Distribution.Simple.Program.Types
import Distribution.Simple.Utils (toUTF8BS)
import Distribution.System (OS (Windows), buildOS)
import Distribution.Types.PackageVersionConstraint
-import Distribution.Version
import Distribution.Parsec
import Distribution.Pretty
@@ -74,16 +72,10 @@ tests =
, testProperty "buildonly" prop_roundtrip_legacytypes_buildonly
, testProperty "specific" prop_roundtrip_legacytypes_specific
]
- ++
- -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older
- -- unclear why as of yet
- concat
- [ [ testProperty "shared" prop_roundtrip_legacytypes_shared
- , testProperty "local" prop_roundtrip_legacytypes_local
- , testProperty "all" prop_roundtrip_legacytypes_all
- ]
- | not usingGhc76orOlder
- ]
+ ++ [ testProperty "shared" prop_roundtrip_legacytypes_shared
+ , testProperty "local" prop_roundtrip_legacytypes_local
+ , testProperty "all" prop_roundtrip_legacytypes_all
+ ]
, testGroup
"individual parser tests"
[ testProperty "package location" prop_parsePackageLocationTokenQ
@@ -103,11 +95,6 @@ tests =
, testGetProjectRootUsability
, testFindProjectRoot
]
- where
- usingGhc76orOlder =
- case buildCompilerId of
- CompilerId GHC v -> v < mkVersion [7, 7]
- _ -> False
testGetProjectRootUsability :: TestTree
testGetProjectRootUsability =
@@ -419,8 +406,7 @@ prop_roundtrip_printparse_RelaxDeps' rdep =
instance Arbitrary ProjectConfig where
arbitrary =
- ProjectConfig
- <$> (map getPackageLocationString <$> arbitrary)
+ (ProjectConfig . map getPackageLocationString <$> arbitrary)
<*> (map getPackageLocationString <$> arbitrary)
<*> shortListOf 3 arbitrary
<*> arbitrary
@@ -601,6 +587,30 @@ instance Arbitrary ProjectConfigBuildOnly where
preShrink_NumJobs = fmap (fmap Positive)
postShrink_NumJobs = fmap (fmap getPositive)
+instance Arbitrary ProjectConfigToolchain where
+ arbitrary = do
+ projectConfigHcFlavor <- arbitrary
+ projectConfigHcPath <- arbitraryFlag arbitraryShortToken
+ projectConfigHcPkg <- arbitraryFlag arbitraryShortToken
+ projectConfigPackageDBs <- shortListOf 2 arbitrary
+ projectConfigBuildHcFlavor <- arbitrary
+ projectConfigBuildHcPath <- arbitraryFlag arbitraryShortToken
+ projectConfigBuildHcPkg <- arbitraryFlag arbitraryShortToken
+ projectConfigBuildPackageDBs <- shortListOf 2 arbitrary
+ return ProjectConfigToolchain{..}
+
+ shrink ProjectConfigToolchain{..} =
+ runShrinker $
+ pure ProjectConfigToolchain
+ <*> shrinker projectConfigHcFlavor
+ <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath
+ <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg
+ <*> shrinker projectConfigPackageDBs
+ <*> shrinker projectConfigBuildHcFlavor
+ <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPath
+ <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPkg
+ <*> shrinker projectConfigBuildPackageDBs
+
instance Arbitrary ProjectConfigShared where
arbitrary = do
projectConfigDistDir <- arbitraryFlag arbitraryShortToken
@@ -609,12 +619,9 @@ instance Arbitrary ProjectConfigShared where
projectConfigProjectFile <- arbitraryFlag arbitraryShortToken
projectConfigProjectFileParser <- arbitraryFlag arbitrary
projectConfigIgnoreProject <- arbitrary
- projectConfigHcFlavor <- arbitrary
- projectConfigHcPath <- arbitraryFlag arbitraryShortToken
- projectConfigHcPkg <- arbitraryFlag arbitraryShortToken
+ projectConfigToolchain <- arbitrary
projectConfigHaddockIndex <- arbitrary
projectConfigInstallDirs <- fixInstallDirs <$> arbitrary
- projectConfigPackageDBs <- shortListOf 2 arbitrary
projectConfigRemoteRepos <- arbitrary
projectConfigLocalNoIndexRepos <- arbitrary
projectConfigActiveRepos <- arbitrary
@@ -656,12 +663,9 @@ instance Arbitrary ProjectConfigShared where
<*> shrinker projectConfigProjectFile
<*> shrinker projectConfigProjectFileParser
<*> shrinker projectConfigIgnoreProject
- <*> shrinker projectConfigHcFlavor
- <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath
- <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg
+ <*> shrinker projectConfigToolchain
<*> shrinker projectConfigHaddockIndex
<*> shrinker projectConfigInstallDirs
- <*> shrinker projectConfigPackageDBs
<*> shrinker projectConfigRemoteRepos
<*> shrinker projectConfigLocalNoIndexRepos
<*> shrinker projectConfigActiveRepos
@@ -702,15 +706,14 @@ instance Arbitrary ProjectConfigProvenance where
instance Arbitrary PackageConfig where
arbitrary =
- PackageConfig
- <$> ( MapLast . Map.fromList
- <$> shortListOf
- 10
- ( (,)
- <$> arbitraryProgramName
- <*> arbitraryShortToken
- )
+ ( PackageConfig . MapLast . Map.fromList
+ <$> shortListOf
+ 10
+ ( (,)
+ <$> arbitraryProgramName
+ <*> arbitraryShortToken
)
+ )
<*> ( MapMappend . Map.fromList
<$> shortListOf
10
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
index ac6d96cc159..cbb16c49477 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
@@ -4,7 +4,7 @@ module UnitTests.Distribution.Client.Targets
import Distribution.Client.Targets
( UserConstraint (..)
- , UserConstraintScope (..)
+ , UserConstraintQualifier (..)
, UserQualifier (..)
, readUserConstraint
)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
index ef4f9fb7c9f..b7db877562e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
@@ -9,6 +9,7 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.ProjectConfigPath
import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.Stage
import Distribution.Client.BuildReports.Types
import Distribution.Client.CmdInstall.ClientInstallFlags
@@ -63,6 +64,7 @@ instance ToExpr ProjectConfig
instance ToExpr ProjectConfigBuildOnly
instance ToExpr ProjectConfigProvenance
instance ToExpr ProjectConfigShared
+instance ToExpr ProjectConfigToolchain
instance ToExpr ProjectFileParser
instance ToExpr RelaxDepMod
instance ToExpr RelaxDeps
@@ -74,11 +76,13 @@ instance ToExpr ReorderGoals
instance ToExpr RepoIndexState
instance ToExpr RepoName
instance ToExpr ReportLevel
+instance ToExpr Stage
instance ToExpr StrongFlags
instance ToExpr Timestamp
instance ToExpr TotalIndexState
instance ToExpr UserConstraint
instance ToExpr UserConstraintScope
+instance ToExpr UserConstraintQualifier
instance ToExpr UserQualifier
instance ToExpr WriteGhcEnvironmentFilesPolicy
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs
index 30edd4fc758..6cc6042f328 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs
@@ -13,15 +13,15 @@ import System.Directory
, getTemporaryDirectory
)
import System.FilePath (())
+import System.IO (hClose, openTempFile)
import Test.Tasty
import Test.Tasty.HUnit
import Distribution.Client.Config
import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))
-import Distribution.Client.Utils (removeExistingFile)
import Distribution.Simple.Setup (ConfigFlags (..), fromFlag, pattern Flag)
-import Distribution.Simple.Utils (withTempDirectory)
+import Distribution.Simple.Utils (removeFileForcibly, withTempDirectory)
import Distribution.Utils.NubList (fromNubList)
import Distribution.Verbosity
@@ -100,8 +100,12 @@ bracketTest =
bracket testSetup testTearDown
where
testSetup :: IO FilePath
- testSetup = fmap ( "test-user-config") getCurrentDirectory
+ testSetup = do
+ cwd <- getCurrentDirectory
+ (configFile, h) <- openTempFile cwd "test-user-config"
+ hClose h
+ pure configFile
testTearDown :: FilePath -> IO ()
testTearDown configFile =
- mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
+ mapM_ removeFileForcibly [configFile, configFile ++ ".backup"]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
index 345da6cda24..49c5eda93bf 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
@@ -453,7 +453,7 @@ instance Arbitrary RepoDirSet where
arbitrary =
sized $ \n ->
oneof $
- [RepoDirSet <$> pure 1]
+ [pure (RepoDirSet 1)]
++ [RepoDirSet <$> choose (2, 5) | n >= 3]
shrink (RepoDirSet n) =
[RepoDirSet i | i <- shrink n, i > 0]
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
index 1cfee249147..aa7540b3e56 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
@@ -78,11 +78,15 @@ import qualified Distribution.Verbosity as C
import qualified Distribution.Version as C
import Language.Haskell.Extension (Extension (..), Language (..))
+import qualified Distribution.Compat.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
+
-- cabal-install
import Distribution.Client.Dependency
import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan
import Distribution.Client.Types
+import Data.Foldable (fold)
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
@@ -96,6 +100,7 @@ import qualified Distribution.Solver.Types.PkgConfigDb as PC
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
+import qualified Distribution.Solver.Types.Stage as Stage
import Distribution.Solver.Types.Variable
import Distribution.Types.UnitId (UnitId)
@@ -392,9 +397,9 @@ exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)
-- these packages.
type ExampleDb = [Either ExampleInstalled ExampleAvailable]
-type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
+type DependencyTree a = C.CondTree C.ConfVar a
-type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a
+type DependencyComponent a = C.CondBranch C.ConfVar a
exDbPkgs :: ExampleDb -> [ExamplePkgName]
exDbPkgs = map (either exInstName exAvName)
@@ -414,7 +419,7 @@ exAvSrcPkg ex =
usedFlags :: Map ExampleFlagName C.PackageFlag
usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]
where
- names = extractFlags $ CD.flatDeps (exAvDeps ex)
+ names = extractFlags $ fold (exAvDeps ex)
in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:
Map.elems $ declaredFlags `Map.union` usedFlags
@@ -610,18 +615,19 @@ exAvSrcPkg ex =
-- any level.
mkTopLevelCondTree
:: forall a
- . Semigroup a
+ . (Semigroup a, L.HasBuildInfo a)
=> a
-> (C.LibraryVisibility -> C.BuildInfo -> a)
-> Dependencies
-> DependencyTree a
mkTopLevelCondTree defaultTopLevel mkComponent deps =
- let condNode = mkCondTree mkComponent deps
+ let condNode :: DependencyTree a
+ condNode = mkCondTree mkComponent deps
in condNode{C.condTreeData = defaultTopLevel <> C.condTreeData condNode}
-- Convert 'Dependencies' into a tree of a specific component type, using
-- the given function to generate each component.
- mkCondTree :: (C.LibraryVisibility -> C.BuildInfo -> a) -> Dependencies -> DependencyTree a
+ mkCondTree :: forall a. L.HasBuildInfo a => (C.LibraryVisibility -> C.BuildInfo -> a) -> Dependencies -> DependencyTree a
mkCondTree mkComponent deps =
let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps)
(directDeps, flaggedDeps) = splitDeps libraryDeps
@@ -647,11 +653,7 @@ exAvSrcPkg ex =
, C.buildable = depsIsBuildable deps
}
in C.CondNode
- { C.condTreeData = component
- , -- TODO: Arguably, build-tools dependencies should also
- -- effect constraints on conditional tree. But no way to
- -- distinguish between them
- C.condTreeConstraints = map mkDirect directDeps
+ { C.condTreeData = L.set L.targetBuildDepends (map mkDirect directDeps) component
, C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps
}
@@ -659,7 +661,9 @@ exAvSrcPkg ex =
mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name)
mkFlagged
- :: (C.LibraryVisibility -> C.BuildInfo -> a)
+ :: forall a
+ . L.HasBuildInfo a
+ => (C.LibraryVisibility -> C.BuildInfo -> a)
-> (ExampleFlagName, Dependencies, Dependencies)
-> DependencyComponent a
mkFlagged mkComponent (f, a, b) =
@@ -719,7 +723,7 @@ exAvSrcPkg ex =
_ -> False
mkSimpleVersion :: ExamplePkgVersion -> C.Version
-mkSimpleVersion n = C.mkVersion [n, 0, 0]
+mkSimpleVersion n = C.mkVersion [n]
mkSimplePkgconfigVersion :: ExamplePkgVersion -> C.PkgconfigVersion
mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion
@@ -755,7 +759,7 @@ exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
exAvPkgId ex =
C.PackageIdentifier
{ pkgName = C.mkPackageName (exAvName ex)
- , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]
+ , pkgVersion = C.mkVersion [exAvVersion ex]
}
exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo
@@ -770,7 +774,7 @@ exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
exInstPkgId ex =
C.PackageIdentifier
{ pkgName = C.mkPackageName (exInstName ex)
- , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]
+ , pkgVersion = C.mkVersion [exInstVersion ex]
}
exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage
@@ -829,7 +833,11 @@ exResolve
prefs
verbosity
enableAllTests =
- resolveDependencies C.buildPlatform compiler pkgConfigDb params
+ resolveDependencies
+ (Stage.always (compiler, C.buildPlatform))
+ (Stage.always pkgConfigDb)
+ (Stage.always instIdx)
+ params
where
defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
compiler =
@@ -863,17 +871,16 @@ exResolve
setCountConflicts countConflicts $
setFineGrainedConflicts fineGrainedConflicts $
setMinimizeConflictSet minimizeConflictSet $
- setIndependentGoals indepGoals $
- (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $
- setReorderGoals reorder $
- setMaxBackjumps mbj $
- setAllowBootLibInstalls allowBootLibInstalls $
- setOnlyConstrained onlyConstrained $
- setEnableBackjumping enableBj $
- setSolveExecutables solveExes $
- setGoalOrder goalOrder $
- setSolverVerbosity (C.verbosityLevel verbosity) $
- standardInstallPolicy instIdx avaiIdx targets'
+ (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $
+ setReorderGoals reorder $
+ setMaxBackjumps mbj $
+ setAllowBootLibInstalls allowBootLibInstalls $
+ setOnlyConstrained onlyConstrained $
+ setEnableBackjumping enableBj $
+ setSolveExecutables solveExes $
+ setGoalOrder goalOrder $
+ setSolverVerbosity (C.verbosityLevel verbosity) $
+ standardInstallPolicy avaiIdx targets'
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
toConstraint (ExVersionConstraint scope v) =
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
index 3fe0eb6a339..f0112ab71aa 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
@@ -34,6 +34,7 @@ import Distribution.Solver.Compat.Prelude
import Prelude ()
import Data.List (elemIndex)
+import GHC.Stack (withFrozenCallStack)
-- test-framework
import Test.Tasty as TF
@@ -50,6 +51,7 @@ import Distribution.Client.Dependency (foldProgress)
import qualified Distribution.Solver.Types.PackagePath as P
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList)
import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.Stage
import Distribution.Solver.Types.Variable
import Distribution.Types.UnitId (UnitId, mkUnitId)
import UnitTests.Distribution.Solver.Modular.DSL
@@ -252,7 +254,7 @@ mkTestExtLangPC exts langs mPkgConfigDb db label targets result =
}
runTest :: SolverTest -> TF.TestTree
-runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
+runTest SolverTest{..} = withFrozenCallStack $ askOption $ \(OptionShowSolverLog showSolverLog) ->
testCase testLabel $ do
let progress =
exResolve
@@ -322,20 +324,10 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
toQPN q pn = P.Q pp (C.mkPackageName pn)
where
pp = case q of
- QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
- QualIndep p ->
- P.PackagePath
- (P.Independent $ C.mkPackageName p)
- P.QualToplevel
+ QualNone -> P.PackagePath Host P.QualToplevel
QualSetup s ->
- P.PackagePath
- P.DefaultNamespace
- (P.QualSetup (C.mkPackageName s))
- QualIndepSetup p s ->
- P.PackagePath
- (P.Independent $ C.mkPackageName p)
- (P.QualSetup (C.mkPackageName s))
+ P.PackagePath Host (P.QualSetup (C.mkPackageName s))
+ QualIndepSetup _ s ->
+ P.PackagePath Host (P.QualSetup (C.mkPackageName s))
QualExe p1 p2 ->
- P.PackagePath
- P.DefaultNamespace
- (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))
+ P.PackagePath Host (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
index eecab420f8c..1ed0710709a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
@@ -43,6 +43,7 @@ import Distribution.Solver.Types.Variable
import Distribution.Verbosity
import Distribution.Version
+import Distribution.Solver.Types.Stage (Stage)
import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils
( ArbitraryOrd (..)
@@ -499,8 +500,8 @@ arbitraryConstraint pkgs = do
(PN pn, v) <- elements pkgs
let anyQualifier = ScopeAnyQualifier (mkPackageName pn)
oneof
- [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v
- , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas]
+ [ ExVersionConstraint (ConstraintScope Nothing anyQualifier) <$> arbitraryVersionRange v
+ , ExStanzaConstraint (ConstraintScope Nothing anyQualifier) <$> sublistOf [TestStanzas, BenchStanzas]
]
arbitraryPreference :: [(PN, PV)] -> Gen ExPreference
@@ -558,7 +559,7 @@ instance Arbitrary Component where
-- internal libraries.
arbitraryUQN :: Gen UnqualComponentName
arbitraryUQN =
- mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"
+ mkUnqualComponentName . (\c -> "component-" ++ [c]) <$> elements "ABC"
instance Arbitrary ExampleInstalled where
arbitrary = error "arbitrary not implemented: ExampleInstalled"
@@ -621,11 +622,16 @@ instance Arbitrary OptionalStanza where
shrink BenchStanzas = [TestStanzas]
shrink TestStanzas = []
+instance Arbitrary Stage where
+ arbitrary = elements [minBound .. maxBound]
+
+ shrink stage =
+ [stage' | stage' <- [minBound .. maxBound], stage' /= stage]
+
instance ArbitraryOrd pn => ArbitraryOrd (Variable pn)
instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a)
instance ArbitraryOrd P.PackagePath
instance ArbitraryOrd P.Qualifier
-instance ArbitraryOrd P.Namespace
instance ArbitraryOrd OptionalStanza
instance ArbitraryOrd FlagName
instance ArbitraryOrd PackageName
@@ -633,12 +639,9 @@ instance ArbitraryOrd ShortText where
arbitraryCompare = do
strc <- arbitraryCompare
pure $ \l r -> strc (fromShortText l) (fromShortText r)
+instance ArbitraryOrd Stage
deriving instance Generic (Variable pn)
-deriving instance Generic (P.Qualified a)
-deriving instance Generic P.PackagePath
-deriving instance Generic P.Namespace
-deriving instance Generic P.Qualifier
randomSubset :: Int -> [a] -> Gen [a]
randomSubset n xs = take n <$> shuffle xs
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs
index 5c1d26a1bc2..8e37ba83787 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs
@@ -35,15 +35,15 @@ tests =
\p (Blind f) ->
toProgress (retry (fromProgress p) (fromProgress . f))
=== (foldProgress Step f Done (p :: Log Int) :: Log Int)
- , testProperty "failWith" $ \step failure ->
- toProgress (failWith step failure)
- === (Step step (Fail failure) :: Log Int)
- , testProperty "succeedWith" $ \step success ->
- toProgress (succeedWith step success)
- === (Step step (Done success) :: Log Int)
- , testProperty "continueWith" $ \step p ->
- toProgress (continueWith step (fromProgress p))
- === (Step step p :: Log Int)
+ , testProperty "failWith" $ \step' failure ->
+ toProgress (failWith step' failure)
+ === (Step step' (Fail failure) :: Log Int)
+ , testProperty "succeedWith" $ \step' success ->
+ toProgress (succeedWith step' success)
+ === (Step step' (Done success) :: Log Int)
+ , testProperty "continueWith" $ \step' p ->
+ toProgress (continueWith step' (fromProgress p))
+ === (Step step' p :: Log Int)
, testCase "tryWith with failure" $
let failure = Fail "Error"
s = Step Success
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
index 10e1511d3be..5cccc11ee1a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
@@ -77,13 +77,13 @@ tests =
any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)"
in runTest $
setVerbose $
- constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $
+ constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "true-dep")) V.noVersion] $
mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $
-- TODO: We should check the summarized log instead of the full log
-- for the manual flags error message, but it currently only
-- appears in the full log.
SolverResult checkFullLog (Left $ const True)
- , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False]
+ , let cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "pkg")) "flag" False]
in runTest $
constraints cs $
mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $
@@ -92,7 +92,7 @@ tests =
, testGroup
"Qualified manual flag constraints"
[ let name = "Top-level flag constraint does not constrain setup dep's flag"
- cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
+ cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False]
in runTest $
constraints cs $
mkTest dbSetupDepWithManualFlag name ["A"] $
@@ -105,8 +105,8 @@ tests =
]
, let name = "Solver can toggle setup dep's flag to match top-level constraint"
cs =
- [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False
- , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion
+ [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False
+ , ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "b-2-true-dep")) V.noVersion
]
in runTest $
constraints cs $
@@ -120,8 +120,8 @@ tests =
]
, let name = "User can constrain flags separately with qualified constraints"
cs =
- [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
- , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False
+ [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True
+ , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False
]
in runTest $
constraints cs $
@@ -135,15 +135,15 @@ tests =
]
, -- Regression test for #4299
let name = "Solver can link deps when only one has constrained manual flag"
- cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
+ cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False]
in runTest $
constraints cs $
mkTest dbLinkedSetupDepWithManualFlag name ["A"] $
solverSuccess [("A", 1), ("B", 1), ("b-1-false-dep", 1)]
, let name = "Solver cannot link deps that have conflicting manual flag constraints"
cs =
- [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
- , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False
+ [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True
+ , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False
]
failureReason = "(constraint from unknown source requires opposite flag selection)"
checkFullLog lns =
@@ -201,13 +201,13 @@ tests =
"Non-reinstallable base, template-haskell and ghc (GHC without wiredInUnitIds)"
[ runTest $
mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $
- solverFailure (isInfixOf "rejecting: base-1.0.0 (constraint from non-reinstallable package requires installed instance)")
+ solverFailure (isInfixOf "rejecting: base-1 (constraint from non-reinstallable package requires installed instance)")
, runTest $
mkTest dbTH "Refuse to install template-haskell without --allow-boot-library-installs" ["template-haskell"] $
- solverFailure (isInfixOf "rejecting: template-haskell-1.0.0 (constraint from non-reinstallable package requires installed instance)")
+ solverFailure (isInfixOf "rejecting: template-haskell-1 (constraint from non-reinstallable package requires installed instance)")
, runTest $
mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $
- solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-reinstallable package requires installed instance)")
+ solverFailure (isInfixOf "rejecting: ghc-2 (constraint from non-reinstallable package requires installed instance)")
, runTest $
allowBootLibInstalls $
mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $
@@ -226,11 +226,11 @@ tests =
, runTest $
wiredInUnitIds $
mkTest dbGhcInternal "Fails to reinstall ghc-internal as its wired-in" ["ghc-internal"] $
- solverFailure (isInfixOf "ghc-internal-1.0.0 (constraint from non-reinstallable package requires installed instance with unit id ghc-internal-1)")
+ solverFailure (isInfixOf "ghc-internal-1 (constraint from non-reinstallable package requires installed instance with unit id ghc-internal-1)")
, runTest $
wiredInUnitIds $
mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $
- solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-reinstallable package requires installed instance with unit id ghc-1)")
+ solverFailure (isInfixOf "rejecting: ghc-2 (constraint from non-reinstallable package requires installed instance with unit id ghc-1)")
]
, testGroup
"reject-unconstrained"
@@ -252,7 +252,7 @@ tests =
solverFailure $
isInfixOf $
"Could not resolve dependencies:\n"
- ++ "[__0] trying: A-3.0.0 (user goal)\n"
+ ++ "[__0] trying: A-3 (user goal)\n"
++ "[__1] next goal: C (dependency of A)\n"
++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, "
++ "but reject-unconstrained-dependencies was set)\n"
@@ -295,20 +295,20 @@ tests =
[ runTest $
mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $
solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)]
- , let cs = [ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4]
+ , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "D")) $ mkVersionRange 1 4]
in runTest $
constraints cs $
mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $
solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]
, let cs =
- [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4
- , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7
+ [ ExVersionConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "D")) $ mkVersionRange 1 4
+ , ExVersionConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "B") "D")) $ mkVersionRange 4 7
]
in runTest $
constraints cs $
mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $
solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)]
- , let cs = [ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4]
+ , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnySetupQualifier "D")) $ mkVersionRange 1 4]
in runTest $
constraints cs $
mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $
@@ -370,8 +370,8 @@ tests =
"Pkg-config dependencies"
[ runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure
, runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure
- , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])
+ , runTest $ mkTestPCDepends (Just [("pkgA", "1"), ("pkgB", "1")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTestPCDepends (Just [("pkgA", "1"), ("pkgB", "2")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])
, runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure
, runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D", 1)])
]
@@ -414,7 +414,7 @@ tests =
]
in runTest $
mkTest db "reject build-depends dependency with no library" ["A"] $
- solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)")
+ solverFailure (isInfixOf "rejecting: B-1 (does not contain library, which is required by A)")
, let exe = exExe "exe" []
db =
[ Right $ exAv "A" 1 [ExAny "B"]
@@ -434,7 +434,7 @@ tests =
in runTest $
mkTest db "reject package that is missing required sub-library" ["A"] $
solverFailure $
- isInfixOf "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)"
+ isInfixOf "rejecting: B-1 (does not contain library 'sub-lib', which is required by A)"
, let db =
[ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
, Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" []
@@ -442,7 +442,7 @@ tests =
in runTest $
mkTest db "reject package with private but required sub-library" ["A"] $
solverFailure $
- isInfixOf "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"
+ isInfixOf "rejecting: B-1 (library 'sub-lib' is private, but it is required by A)"
, let db =
[ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
, Right $
@@ -450,10 +450,10 @@ tests =
`withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies]
]
in runTest $
- constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $
+ constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "make-lib-private" True] $
mkTest db "reject package with sub-library made private by flag constraint" ["A"] $
solverFailure $
- isInfixOf "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"
+ isInfixOf "rejecting: B-1 (library 'sub-lib' is private, but it is required by A)"
, let db =
[ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
, Right $
@@ -478,7 +478,7 @@ tests =
goalOrder goals $
mkTest db "reject package that requires a private sub-library" ["A", "C"] $
solverFailure $
- isInfixOf "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)"
+ isInfixOf "rejecting: C-1 (requires library 'sub-lib' from B, but the component is private)"
, let db =
[ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"]
, Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies
@@ -530,9 +530,9 @@ tests =
isInfixOf $
-- The solver reports the version conflict when a version conflict
-- and an executable conflict apply to the same package version.
- "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n"
- ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n"
- ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)"
+ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3)\n"
+ ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3 (does not contain executable 'exe1', which is required by H)\n"
+ ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3)"
, runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success"
, runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure"
, runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency"
@@ -563,7 +563,7 @@ tests =
]
, -- tests for partial fix for issue #5325
testGroup "Components that are unbuildable in the current environment" $
- let flagConstraint = ExFlagConstraint . ScopeAnyQualifier
+ let flagConstraint = ExFlagConstraint . ConstraintScope Nothing . ScopeAnyQualifier
in [ let db = [Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]]
in runTest $
constraints [flagConstraint "A" "build-lib" False] $
@@ -587,7 +587,7 @@ tests =
mkTest db "reject library dependency with unbuildable library" ["A"] $
solverFailure $
isInfixOf $
- "rejecting: B-1.0.0 (library is not buildable in the "
+ "rejecting: B-1 (library is not buildable in the "
++ "current environment, but it is required by A)"
, let db =
[ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]
@@ -610,7 +610,7 @@ tests =
mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $
solverFailure $
isInfixOf $
- "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not "
+ "rejecting: A:B:exe.B-1 (executable 'bt' is not "
++ "buildable in the current environment, but it is required by A)"
, runTest $
chooseUnbuildableExeAfterBuildToolsPackage
@@ -633,17 +633,17 @@ tests =
, Right $ exAv "B" 1 [ExAny "unknown2"]
]
msg =
- [ "[__0] trying: A-4.0.0 (user goal)"
- , "[__1] trying: B-2.0.0 (dependency of A)"
+ [ "[__0] trying: A-4 (user goal)"
+ , "[__1] trying: B-2 (dependency of A)"
, "[__2] unknown package: unknown1 (dependency of B)"
, "[__2] fail (backjumping, conflict set: B, unknown1)"
- , "[__1] trying: B-1.0.0"
+ , "[__1] trying: B-1"
, "[__2] unknown package: unknown2 (dependency of B)"
, "[__2] fail (backjumping, conflict set: B, unknown2)"
, "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)"
- , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that "
+ , "[__0] skipping: A; 3, 2 (has the same characteristics that "
++ "caused the previous version to fail: depends on 'B')"
- , "[__0] trying: A-1.0.0"
+ , "[__0] trying: A-1"
, "[__1] done"
]
in setVerbose $
@@ -666,16 +666,16 @@ tests =
, Right $ exAv "B" 11 []
]
msg =
- [ "[__0] trying: A-4.0.0 (user goal)"
+ [ "[__0] trying: A-4 (user goal)"
, "[__1] next goal: B (dependency of A)"
- , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)"
+ , "[__1] rejecting: B-11 (conflict: A => B==14)"
, "[__1] fail (backjumping, conflict set: A, B)"
- , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that "
+ , "[__0] skipping: A; 3, 2 (has the same characteristics that "
++ "caused the previous version to fail: depends on 'B' but excludes "
- ++ "version 11.0.0)"
- , "[__0] trying: A-1.0.0"
+ ++ "version 11)"
+ , "[__0] trying: A-1"
, "[__1] next goal: B (dependency of A)"
- , "[__1] trying: B-11.0.0"
+ , "[__1] trying: B-11"
, "[__2] done"
]
in setVerbose $
@@ -704,16 +704,16 @@ tests =
]
goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]
expectedMsg =
- [ "[__0] trying: A-1.0.0 (user goal)"
- , "[__1] trying: B-3.0.0 (dependency of A)"
+ [ "[__0] trying: A-1 (user goal)"
+ , "[__1] trying: B-3 (dependency of A)"
, "[__2] next goal: C (dependency of A)"
- , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)"
- , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the "
- ++ "previous version to fail: excludes 'B' version 3.0.0)"
+ , "[__2] rejecting: C-2 (conflict: B==3, C => B==2)"
+ , "[__2] skipping: C-1 (has the same characteristics that caused the "
+ ++ "previous version to fail: excludes 'B' version 3)"
, "[__2] fail (backjumping, conflict set: A, B, C)"
- , "[__1] trying: B-2.0.0"
+ , "[__1] trying: B-2"
, "[__2] next goal: C (dependency of A)"
- , "[__2] trying: C-2.0.0"
+ , "[__2] trying: C-2"
, "[__3] done"
]
in setVerbose $
@@ -744,22 +744,22 @@ tests =
]
goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]
msg =
- [ "[__0] trying: A-3.0.0 (user goal)"
- , "[__1] trying: B-1.0.0 (dependency of A)"
- , "[__2] trying: C-1.0.0 (dependency of A)"
+ [ "[__0] trying: A-3 (user goal)"
+ , "[__1] trying: B-1 (dependency of A)"
+ , "[__2] trying: C-1 (dependency of A)"
, "[__3] next goal: D (dependency of B)"
- , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"
- , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)"
+ , "[__3] rejecting: D-2 (conflict: B => D==1)"
+ , "[__3] rejecting: D-1 (conflict: C => D==2)"
, "[__3] fail (backjumping, conflict set: B, C, D)"
, "[__2] fail (backjumping, conflict set: A, B, C, D)"
, "[__1] fail (backjumping, conflict set: A, B, C, D)"
- , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the "
+ , "[__0] skipping: A-2 (has the same characteristics that caused the "
++ "previous version to fail: depends on 'B'; depends on 'C')"
- , "[__0] trying: A-1.0.0"
- , "[__1] trying: B-1.0.0 (dependency of A)"
+ , "[__0] trying: A-1"
+ , "[__1] trying: B-1 (dependency of A)"
, "[__2] next goal: D (dependency of B)"
- , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"
- , "[__2] trying: D-1.0.0"
+ , "[__2] rejecting: D-2 (conflict: B => D==1)"
+ , "[__2] trying: D-1"
, "[__3] done"
]
in setVerbose $
@@ -788,18 +788,17 @@ tests =
]
goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]
msg =
- [ "[__0] trying: A-4.0.0 (user goal)"
+ [ "[__0] trying: A-4 (user goal)"
, "[__1] next goal: B (dependency of A)"
- , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"
- , "[__1] trying: B-1.0.0"
+ , "[__1] rejecting: B-2 (conflict: A => B==1)"
+ , "[__1] trying: B-1"
, "[__2] next goal: C (dependency of A)"
- , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)"
+ , "[__2] rejecting: C-2 (conflict: A => C==1)"
, "[__2] fail (backjumping, conflict set: A, C)"
- , "[__0] skipping: A; 3.0.0, 2.0.0 (has the same characteristics that caused the "
- ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)"
- , "[__0] trying: A-1.0.0"
+ , "[__0] skipping: A; 3, 2 (has the same characteristics that caused the previous version to fail: depends on 'C' but excludes version 2)"
+ , "[__0] trying: A-1"
, "[__1] next goal: C (dependency of A)"
- , "[__1] trying: C-2.0.0"
+ , "[__1] trying: C-2"
, "[__2] done"
]
in setVerbose $
@@ -818,7 +817,7 @@ tests =
, Right $ exAv "B" 1 []
]
msg =
- [ "[__0] trying: A-2.0.0 (user goal)"
+ [ "[__0] trying: A-2 (user goal)"
, "[__1] next goal: B (dependency of A)"
, -- During this step, the solver adds A and B to the
-- conflict set, with the details of each package's
@@ -826,7 +825,7 @@ tests =
--
-- A: A's constraint rejected B-2.
-- B: B was rejected by A's B==3 constraint
- "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)"
+ "[__1] rejecting: B-2 (conflict: A => B==3)"
, -- When the solver skips B-1, it cannot simply reuse the
-- previous conflict set. It also needs to update A's
-- entry to say that A also rejected B-1. Otherwise, the
@@ -834,13 +833,13 @@ tests =
-- the conflicts encountered while exploring A-2. The
-- solver would skip A-1, even though it leads to the
-- solution.
- "[__1] skipping: B-1.0.0 (has the same characteristics that caused "
- ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')"
+ "[__1] skipping: B-1 (has the same characteristics that caused "
+ ++ "the previous version to fail: excluded by constraint '==3' from 'A')"
, "[__1] fail (backjumping, conflict set: A, B)"
- , "[__0] trying: A-1.0.0"
+ , "[__0] trying: A-1"
, "[__1] next goal: B (dependency of A)"
- , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"
- , "[__1] trying: B-1.0.0"
+ , "[__1] rejecting: B-2 (conflict: A => B==1)"
+ , "[__1] trying: B-1"
, "[__2] done"
]
in setVerbose $
@@ -859,16 +858,16 @@ tests =
]
goals = [P QualNone pkg | pkg <- ["A", "B"]]
msg =
- [ "[__0] trying: A-2.0.0 (user goal)"
+ [ "[__0] trying: A-2 (user goal)"
, "[__1] next goal: B (user goal)"
- , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)"
- , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "
- ++ "the previous version to fail: excludes 'A' version 2.0.0)"
+ , "[__1] rejecting: B-2 (conflict: A==2, B => A==3)"
+ , "[__1] skipping: B-1 (has the same characteristics that caused "
+ ++ "the previous version to fail: excludes 'A' version 2)"
, "[__1] fail (backjumping, conflict set: A, B)"
- , "[__0] trying: A-1.0.0"
+ , "[__0] trying: A-1"
, "[__1] next goal: B (user goal)"
- , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)"
- , "[__1] trying: B-1.0.0"
+ , "[__1] rejecting: B-2 (conflict: A==1, B => A==3)"
+ , "[__1] trying: B-1"
, "[__2] done"
]
in setVerbose $
@@ -901,15 +900,15 @@ tests =
solverFailure (isInfixOf msg)
, testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $
"Could not resolve dependencies:\n"
- ++ "[__0] trying: A-1.0.0 (user goal)\n"
+ ++ "[__0] trying: A-1 (user goal)\n"
++ "[__1] unknown package: F (dependency of A)\n"
++ "[__1] fail (backjumping, conflict set: A, F)\n"
++ "After searching the rest of the dependency tree exhaustively, "
++ "these were the goals I've had most trouble fulfilling: A, F"
, testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $
"Could not resolve dependencies:\n"
- ++ "[__0] trying: A-1.0.0 (user goal)\n"
- ++ "[__1] trying: B-3.0.0 (dependency of A)\n"
+ ++ "[__0] trying: A-1 (user goal)\n"
+ ++ "[__1] trying: B-3 (dependency of A)\n"
++ "[__2] unknown package: C (dependency of B)\n"
++ "[__2] fail (backjumping, conflict set: B, C)\n"
++ "Backjump limit reached (currently 3, change with --max-backjumps "
@@ -925,9 +924,9 @@ tests =
, runTest $
let db =
[ Right $ exAv "my-package" 1 [ExFix "other-package" 3]
- , Left $ exInst "other-package" 2 "other-package-2.0.0" []
+ , Left $ exInst "other-package" 2 "other-package-2" []
]
- msg = "rejecting: other-package-2.0.0/installed-2.0.0"
+ msg = "rejecting: other-package-2/installed-2"
in mkTest db "show full installed package version (issue #5892)" ["my-package"] $
solverFailure (isInfixOf msg)
, runTest $
@@ -935,7 +934,7 @@ tests =
[ Right $ exAv "my-package" 1 [ExFix "other-package" 3]
, Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" []
]
- msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789"
+ msg = "rejecting: other-package-2/installed-AbCdEfGhIj0123456789"
in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $
solverFailure (isInfixOf msg)
, testGroup
@@ -946,18 +945,18 @@ tests =
, Right $ exAv "A" 2 []
, Right $ exAv "B" 1 [ExFix "A" 3]
]
- rejecting = "rejecting: A-2.0.0"
- skipping = "skipping: A-1.0.0"
+ rejecting = "rejecting: A-2"
+ skipping = "skipping: A-1"
in mkTest db "show skipping singleton" ["B"] $
solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
, runTest $
let db =
- [ Left $ exInst "A" 1 "A-1.0.0" []
- , Left $ exInst "A" 2 "A-2.0.0" []
+ [ Left $ exInst "A" 1 "A-1" []
+ , Left $ exInst "A" 2 "A-2" []
, Right $ exAv "B" 1 [ExFix "A" 3]
]
- rejecting = "rejecting: A-2.0.0/installed-2.0.0"
- skipping = "skipping: A-1.0.0/installed-1.0.0"
+ rejecting = "rejecting: A-2/installed-2"
+ skipping = "skipping: A-1/installed-1"
in mkTest db "show skipping singleton, installed" ["B"] $
solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
, runTest $
@@ -967,19 +966,19 @@ tests =
, Right $ exAv "A" 3 []
, Right $ exAv "B" 1 [ExFix "A" 4]
]
- rejecting = "rejecting: A-3.0.0"
- skipping = "skipping: A; 2.0.0, 1.0.0"
+ rejecting = "rejecting: A-3"
+ skipping = "skipping: A; 2, 1"
in mkTest db "show skipping versions list" ["B"] $
solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
, runTest $
let db =
- [ Left $ exInst "A" 1 "A-1.0.0" []
- , Left $ exInst "A" 2 "A-2.0.0" []
- , Left $ exInst "A" 3 "A-3.0.0" []
+ [ Left $ exInst "A" 1 "A-1" []
+ , Left $ exInst "A" 2 "A-2" []
+ , Left $ exInst "A" 3 "A-3" []
, Right $ exAv "B" 1 [ExFix "A" 4]
]
- rejecting = "rejecting: A-3.0.0/installed-3.0.0"
- skipping = "skipping: A; 2.0.0/installed-2.0.0, 1.0.0/installed-1.0.0"
+ rejecting = "rejecting: A-3/installed-3"
+ skipping = "skipping: A; 2/installed-2, 1/installed-1"
in mkTest db "show skipping versions list, installed" ["B"] $
solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
]
@@ -989,7 +988,7 @@ tests =
indep = independentGoals
mkvrThis = V.thisVersion . makeV
mkvrOrEarlier = V.orEarlierVersion . makeV
- makeV v = V.mkVersion [v, 0, 0]
+ makeV v = V.mkVersion [v]
data GoalOrder = FixedGoalOrder | DefaultGoalOrder
@@ -1420,17 +1419,24 @@ dbBase =
dbTH :: ExampleDb
dbTH =
- [ Right $
- exAv
- "template-haskell"
- 1
- [ExAny "ghc-prim", ExAny "ghc-internal", ExAny "ghc-boot-th", ExAny "pretty", ExAny "base"]
- , Right $ exAv "ghc-prim" 1 []
- , Left $ exInst "ghc-internal" 1 "ghc-internal-1" []
- , Left $ exInst "ghc-boot-th" 1 "ghc-boot-th-1" []
- , Right $ exAv "pretty" 1 [ExAny "base"]
- , Right $ exAv "base" 1 [ExAny "ghc-prim", ExAny "ghc-internal"]
- ]
+ -- Base without upperbound will trip the "missing-bounds-important" error. We set the upperbound to a very high upper bound to avoid it.
+ let boundedBase = ExRange "base" 0 999
+ in [ Right $
+ exAv
+ "template-haskell"
+ 1
+ [ ExAny "ghc-prim"
+ , ExAny "ghc-internal"
+ , ExAny "ghc-boot-th"
+ , ExAny "pretty"
+ , boundedBase
+ ]
+ , Right $ exAv "ghc-prim" 1 []
+ , Left $ exInst "ghc-internal" 1 "ghc-internal-1" []
+ , Left $ exInst "ghc-boot-th" 1 "ghc-boot-th-1" []
+ , Right $ exAv "pretty" 1 [boundedBase]
+ , Right $ exAv "base" 1 [ExAny "ghc-prim", ExAny "ghc-internal"]
+ ]
dbGhcInternal :: ExampleDb
dbGhcInternal =
@@ -1578,7 +1584,7 @@ issue4161 name =
checkFullLog =
any $
isInfixOf $
- "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "
+ "rejecting: time:setup.time~>time-2 (cyclic dependencies; "
++ "conflict set: time:setup.time)"
-- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack
@@ -1609,7 +1615,7 @@ testCyclicDependencyErrorMessages name =
checkSummarizedLog :: String -> Bool
checkSummarizedLog =
- isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"
+ isInfixOf "rejecting: pkg-C-1 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"
-- Solve for pkg-D and pkg-E last.
goals :: [ExampleVar]
@@ -1755,9 +1761,9 @@ commonDependencyLogMessage name =
mkTest db name ["A"] $
solverFailure $
isInfixOf $
- "[__0] trying: A-1.0.0 (user goal)\n"
+ "[__0] trying: A-1 (user goal)\n"
++ "[__1] next goal: B (dependency of A +/-flagA)\n"
- ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"
+ ++ "[__1] rejecting: B-2 (conflict: A +/-flagA => B==1 || ==3)"
where
db :: ExampleDb
db =
@@ -2057,7 +2063,7 @@ dbLangs1 =
-- If you specify `A == 2`, that top-level should /not/ apply to an independent goal!
testIndepGoals7 :: String -> SolverTest
testIndepGoals7 name =
- constraints [ExVersionConstraint (scopeToplevel "A") (V.thisVersion (V.mkVersion [2, 0, 0]))] $
+ constraints [ExVersionConstraint (scopeToplevel "A") (V.thisVersion (V.mkVersion [2]))] $
independentGoals $
mkTest dbIndepGoals78 name ["A"] $
-- The more recent version should be picked by the solver. As said
@@ -2075,7 +2081,7 @@ dbIndepGoals78 =
-- If you specify `any.A == 2`, then that should apply inside an independent goal.
testIndepGoals8 :: String -> SolverTest
testIndepGoals8 name =
- constraints [ExVersionConstraint (ScopeAnyQualifier "A") (V.thisVersion (V.mkVersion [2, 0, 0]))] $
+ constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "A")) (V.thisVersion (V.mkVersion [2]))] $
independentGoals $
mkTest dbIndepGoals78 name ["A"] $
solverSuccess [("A", 2)]
@@ -2233,9 +2239,9 @@ testMinimizeConflictSet testName =
expectedMsg =
"Could not resolve dependencies:\n"
- ++ "[__0] trying: A-3.0.0 (user goal)\n"
+ ++ "[__0] trying: A-3 (user goal)\n"
++ "[__1] next goal: D (dependency of A)\n"
- ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n"
+ ++ "[__1] rejecting: D-1 (conflict: A => D==2)\n"
++ "[__1] fail (backjumping, conflict set: A, D)\n"
++ "After searching the rest of the dependency tree exhaustively, these "
++ "were the goals I've had most trouble fulfilling: A (5), D (4)"
@@ -2257,9 +2263,9 @@ testNoMinimizeConflictSet testName =
where
expectedMsg =
"Could not resolve dependencies:\n"
- ++ "[__0] trying: A-3.0.0 (user goal)\n"
+ ++ "[__0] trying: A-3 (user goal)\n"
++ "[__1] next goal: B (dependency of A)\n"
- ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n"
+ ++ "[__1] rejecting: B-1 (conflict: A => B==2)\n"
++ "[__1] fail (backjumping, conflict set: A, B)\n"
++ "After searching the rest of the dependency tree exhaustively, "
++ "these were the goals I've had most trouble fulfilling: "
@@ -2409,7 +2415,7 @@ rejectInstalledBuildToolPackage name =
mkTest db name ["A"] $
solverFailure $
isInfixOf $
- "rejecting: A:B:exe.B-1.0.0/installed-1 "
+ "rejecting: A:B:exe.B-1/installed-1 "
++ "(does not contain executable 'exe', which is required by A)"
where
db :: ExampleDb
@@ -2473,8 +2479,8 @@ requireConsistentBuildToolVersions name =
mkTest db name ["A"] $
solverFailure $
isInfixOf $
- "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n"
- ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)"
+ "[__1] rejecting: A:B:exe.B-2 (conflict: A => A:B:exe.B (exe exe1)==1)\n"
+ ++ "[__1] rejecting: A:B:exe.B-1 (conflict: A => A:B:exe.B (exe exe2)==2)"
where
db :: ExampleDb
db =
@@ -2496,7 +2502,7 @@ requireConsistentBuildToolVersions name =
-- instead of missing.
chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest
chooseUnbuildableExeAfterBuildToolsPackage name =
- constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $
+ constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "build-bt2" False] $
goalOrder goals $
mkTest db name ["A"] $
solverFailure $
@@ -2612,7 +2618,7 @@ setupStanzaTest1 = constraints [ExStanzaConstraint (scopeToplevel "B") [TestStan
-- With the "any" qualifier syntax
setupStanzaTest2 :: SolverTest
setupStanzaTest2 =
- constraints [ExStanzaConstraint (ScopeAnyQualifier "B") [TestStanzas]] $
+ constraints [ExStanzaConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) [TestStanzas]] $
mkTest
dbSetupStanza
"setupStanzaTest2"
diff --git a/cabal-testsuite/PackageTests/AutogenModules/MainIsBench/cabal.out b/cabal-testsuite/PackageTests/AutogenModules/MainIsBench/cabal.out
index 2dcf5fb76a3..cdeb8bd23d3 100644
--- a/cabal-testsuite/PackageTests/AutogenModules/MainIsBench/cabal.out
+++ b/cabal-testsuite/PackageTests/AutogenModules/MainIsBench/cabal.out
@@ -6,7 +6,11 @@ In order, the following will be built:
Configuring benchmark 'Bench' for MainIsBench-0.1...
Preprocessing benchmark 'Bench' for MainIsBench-0.1...
Building benchmark 'Bench' for MainIsBench-0.1...
+Error: [Cabal-7125]
+Failed to build MainIsBench-0.1-inplace-Bench. The exception was:
+ -----BEGIN CABAL OUTPUT-----
Error: [Cabal-2115]
MyDummy.hs doesn't exist
-Error: [Cabal-7125]
-Failed to build MainIsBench-0.1-inplace-Bench.
+CallStack (from HasCallStack):
+ dieWithException, called at src/Distribution/Simple/Utils.hs:1392:16 in Cabal-3.17.0.0-inplace:Distribution.Simple.Utils
+
diff --git a/cabal-testsuite/PackageTests/AutogenModules/MainIsExe/cabal.out b/cabal-testsuite/PackageTests/AutogenModules/MainIsExe/cabal.out
index 7387156e3df..8827fa76844 100644
--- a/cabal-testsuite/PackageTests/AutogenModules/MainIsExe/cabal.out
+++ b/cabal-testsuite/PackageTests/AutogenModules/MainIsExe/cabal.out
@@ -5,7 +5,11 @@ In order, the following will be built:
- MainIsExe-0.1 (exe:Exe) (first run)
Configuring executable 'Exe' for MainIsExe-0.1...
Preprocessing executable 'Exe' for MainIsExe-0.1...
+Error: [Cabal-7125]
+Failed to build MainIsExe-0.1-inplace-Exe. The exception was:
+ -----BEGIN CABAL OUTPUT-----
Error: [Cabal-7554]
can't find source for MyDummy in ., cabal.dist/work/./dist/build//ghc-/MainIsExe-0.1/x/Exe/build/Exe/autogen, cabal.dist/work/./dist/build//ghc-/MainIsExe-0.1/x/Exe/build/global-autogen
-Error: [Cabal-7125]
-Failed to build MainIsExe-0.1-inplace-Exe.
+CallStack (from HasCallStack):
+ dieWithException, called at src/Distribution/Simple/PreProcess.hs:315:13 in Cabal-3.17.0.0-inplace:Distribution.Simple.PreProcess
+
diff --git a/cabal-testsuite/PackageTests/AutogenModules/MainIsTest/cabal.out b/cabal-testsuite/PackageTests/AutogenModules/MainIsTest/cabal.out
index 40ea284ae56..c77c17854f4 100644
--- a/cabal-testsuite/PackageTests/AutogenModules/MainIsTest/cabal.out
+++ b/cabal-testsuite/PackageTests/AutogenModules/MainIsTest/cabal.out
@@ -6,7 +6,11 @@ In order, the following will be built:
Configuring test suite 'Test' for MainIsTest-0.1...
Preprocessing test suite 'Test' for MainIsTest-0.1...
Building test suite 'Test' for MainIsTest-0.1...
+Error: [Cabal-7125]
+Failed to build MainIsTest-0.1-inplace-Test. The exception was:
+ -----BEGIN CABAL OUTPUT-----
Error: [Cabal-2115]
MyDummy.hs doesn't exist
-Error: [Cabal-7125]
-Failed to build MainIsTest-0.1-inplace-Test.
+CallStack (from HasCallStack):
+ dieWithException, called at src/Distribution/Simple/Utils.hs:1392:16 in Cabal-3.17.0.0-inplace:Distribution.Simple.Utils
+
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out
index d1e33f130cf..cdf8656f78f 100644
--- a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out
+++ b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out
@@ -1,5 +1,6 @@
# Setup configure
Configuring Fail1-0.1.0.0...
Error:
- Non-library component has unfilled requirements: UnfilledSig
+ Non-library component has unfilled requirements:
+ UnfilledSig brought into scope by build-depends: Fail1
In the stanza executable foo
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out
index d1e33f130cf..cdf8656f78f 100644
--- a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out
+++ b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out
@@ -1,5 +1,6 @@
# Setup configure
Configuring Fail1-0.1.0.0...
Error:
- Non-library component has unfilled requirements: UnfilledSig
+ Non-library component has unfilled requirements:
+ UnfilledSig brought into scope by build-depends: Fail1
In the stanza executable foo
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs
index 64f462ef12f..0d36a8852b8 100644
--- a/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs
+++ b/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs
@@ -3,4 +3,5 @@ main = setupAndCabalTest $ do
skipUnlessGhcVersion ">= 8.1"
r <- fails $ setup' "configure" []
assertOutputContains "UnfilledSig" r
+ assertOutputContains "brought into scope by" r
return ()
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/Fail4.cabal b/cabal-testsuite/PackageTests/Backpack/Fail4/Fail4.cabal
new file mode 100644
index 00000000000..eb53549bab9
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/Fail4.cabal
@@ -0,0 +1,24 @@
+cabal-version: 3.0
+name: Fail4
+version: 0.1.0.0
+license: BSD-3-Clause
+author: Edward Z. Yang
+maintainer: ezyang@cs.stanford.edu
+build-type: Simple
+
+library sig-lib-a
+ signatures: UnfilledSig
+ build-depends: base
+ hs-source-dirs: lib-a
+ default-language: Haskell2010
+
+library sig-lib-b
+ signatures: UnfilledSig
+ build-depends: base
+ hs-source-dirs: lib-b
+ default-language: Haskell2010
+
+executable foo
+ build-depends: Fail4:sig-lib-a, Fail4:sig-lib-b
+ main-is: Main.hs
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/Main.hs b/cabal-testsuite/PackageTests/Backpack/Fail4/Main.hs
new file mode 100644
index 00000000000..b3549c2fe3d
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/Main.hs
@@ -0,0 +1 @@
+main = return ()
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/lib-a/UnfilledSig.hsig b/cabal-testsuite/PackageTests/Backpack/Fail4/lib-a/UnfilledSig.hsig
new file mode 100644
index 00000000000..567af716f6c
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/lib-a/UnfilledSig.hsig
@@ -0,0 +1 @@
+signature UnfilledSig where
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/lib-b/UnfilledSig.hsig b/cabal-testsuite/PackageTests/Backpack/Fail4/lib-b/UnfilledSig.hsig
new file mode 100644
index 00000000000..567af716f6c
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/lib-b/UnfilledSig.hsig
@@ -0,0 +1 @@
+signature UnfilledSig where
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/setup.cabal.out b/cabal-testsuite/PackageTests/Backpack/Fail4/setup.cabal.out
new file mode 100644
index 00000000000..97c0f360bfb
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/setup.cabal.out
@@ -0,0 +1,8 @@
+# Setup configure
+Configuring Fail4-0.1.0.0...
+Error:
+ Non-library component has unfilled requirements:
+ UnfilledSig
+ brought into scope by build-depends: Fail4:sig-lib-a
+ brought into scope by build-depends: Fail4:sig-lib-b
+ In the stanza executable foo
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/setup.out b/cabal-testsuite/PackageTests/Backpack/Fail4/setup.out
new file mode 100644
index 00000000000..97c0f360bfb
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/setup.out
@@ -0,0 +1,8 @@
+# Setup configure
+Configuring Fail4-0.1.0.0...
+Error:
+ Non-library component has unfilled requirements:
+ UnfilledSig
+ brought into scope by build-depends: Fail4:sig-lib-a
+ brought into scope by build-depends: Fail4:sig-lib-b
+ In the stanza executable foo
diff --git a/cabal-testsuite/PackageTests/Backpack/Fail4/setup.test.hs b/cabal-testsuite/PackageTests/Backpack/Fail4/setup.test.hs
new file mode 100644
index 00000000000..dd901b1aa58
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Backpack/Fail4/setup.test.hs
@@ -0,0 +1,9 @@
+import Test.Cabal.Prelude
+
+main = setupAndCabalTest $ do
+ skipUnlessGhcVersion ">= 8.1"
+ r <- fails $ setup' "configure" []
+ assertOutputContains "UnfilledSig" r
+ assertOutputContains "brought into scope by build-depends: Fail4:sig-lib-a" r
+ assertOutputContains "brought into scope by build-depends: Fail4:sig-lib-b" r
+ return ()
diff --git a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.out b/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.out
deleted file mode 100644
index 512a50e37ee..00000000000
--- a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.out
+++ /dev/null
@@ -1,10 +0,0 @@
-# cabal v2-build
-Resolving dependencies...
-Build profile: -w ghc- -O1
-In order, the following will be built:
- - pkg-0 (lib) (first run)
-Configuring library for pkg-0...
-Error: [Cabal-5559]
-[autogen-guard] To use the autogenerated module PackageInfo_* you need to specify `cabal-version: 3.12` or higher.
-Error: [Cabal-7125]
-Failed to build pkg-0-inplace. The failure occurred during the configure step.
diff --git a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs b/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs
index 0711dcccfe1..5bdb7ead190 100644
--- a/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs
+++ b/cabal-testsuite/PackageTests/BuildAutogenPackageGuard/cabal.test.hs
@@ -4,5 +4,6 @@ import Test.Cabal.Prelude
-- build failure.
main = cabalTest $ do
withProjectFile "cabal.project" $ do
- fails $ cabal "v2-build" ["pkg"]
+ res <- recordMode DoNotRecord $ fails $ cabal' "v2-build" ["pkg"]
+ assertOutputContains "[autogen-guard]" res
diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project
new file mode 100644
index 00000000000..d2c5a6cfbb8
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.project
@@ -0,0 +1 @@
+packages: hello
diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs
new file mode 100644
index 00000000000..41aa448a408
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerOption/cabal.test.hs
@@ -0,0 +1,7 @@
+import Test.Cabal.Prelude
+
+-- Test that --with-build-compiler is accepted and the build succeeds.
+-- Requires --with-build-compiler to be passed to the test runner; skipped otherwise.
+main = cabalTest . recordMode DoNotRecord $ do
+ withBuildCompiler $ \bc ->
+ cabal "v2-build" ["--with-build-compiler=" ++ bc, "all"]
diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs
new file mode 100644
index 00000000000..98f25e48d5a
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/Main.hs
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = putStrLn "Hello, World!"
diff --git a/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal
new file mode 100644
index 00000000000..c343c4c8790
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerOption/hello/hello.cabal
@@ -0,0 +1,10 @@
+cabal-version: >= 1.10
+name: hello
+version: 0.1.0.0
+license: BSD3
+build-type: Simple
+
+executable hello-world
+ main-is: Main.hs
+ build-depends: base
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project
new file mode 100644
index 00000000000..7c64e37f6d3
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.project
@@ -0,0 +1 @@
+packages: client
diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs
new file mode 100644
index 00000000000..1a6ec419128
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/cabal.test.hs
@@ -0,0 +1,23 @@
+import Test.Cabal.Prelude
+
+main :: IO ()
+main = cabalTest . recordMode DoNotRecord $ do
+ withBuildCompiler $ \bc -> do
+ cabal "v2-build" ["--with-build-compiler=" ++ bc, "all"]
+ -- Ask the build compiler for its numeric version (e.g. "9.10.2")
+ -- and convert it to the __GLASGOW_HASKELL__ integer format (e.g. 910).
+ vr <- runM bc ["--numeric-version"] Nothing
+ let bcInt = ghcNumericVersionToGHC (head (lines (resultOutput vr)))
+ withPlan $ do
+ r <- runPlanExe' "client" "check-compiler" []
+ assertOutputContains ("setup-ghc: " ++ show bcInt) r
+
+-- Convert a GHC numeric version string "M.N.P" to the __GLASGOW_HASKELL__
+-- integer M*100 + N (e.g. "9.10.2" -> 910).
+ghcNumericVersionToGHC :: String -> Int
+ghcNumericVersionToGHC s = major * 100 + minor
+ where
+ (majorStr, rest) = span (/= '.') s
+ (minorStr, _) = span (/= '.') (drop 1 rest)
+ major = read majorStr
+ minor = read minorStr
diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs
new file mode 100644
index 00000000000..c529d03ecb2
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Main.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+module Main where
+
+main :: IO ()
+main = do
+ -- SETUP_GHC_VERSION is injected by Setup.hs using the build compiler's
+ -- __GLASGOW_HASKELL__ macro, so it reflects the build-stage GHC.
+ putStrLn $ "setup-ghc: " ++ show (SETUP_GHC_VERSION :: Int)
+ -- __GLASGOW_HASKELL__ here reflects the host compiler (the one compiling Main.hs).
+ putStrLn $ "self-ghc: " ++ show (__GLASGOW_HASKELL__ :: Int)
diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs
new file mode 100644
index 00000000000..f4a03e2b3ca
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/Setup.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP #-}
+module Main where
+
+import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Setup
+import Distribution.PackageDescription
+import Distribution.Types.BuildInfo
+
+main :: IO ()
+main = defaultMainWithHooks simpleUserHooks{confHook = myConfHook}
+
+myConfHook
+ :: (GenericPackageDescription, HookedBuildInfo)
+ -> ConfigFlags
+ -> IO LocalBuildInfo
+myConfHook pkg flags = do
+ lbi <- confHook simpleUserHooks pkg flags
+ -- __GLASGOW_HASKELL__ is the version of GHC compiling this Setup.hs,
+ -- i.e. the build compiler in a cross-compile scenario.
+ let define = "-DSETUP_GHC_VERSION=" ++ show (__GLASGOW_HASKELL__ :: Int)
+ addDefine bi = bi{cppOptions = define : cppOptions bi}
+ pd = localPkgDescr lbi
+ exes' = map (\e -> e{buildInfo = addDefine (buildInfo e)}) (executables pd)
+ return lbi{localPkgDescr = pd{executables = exes'}}
diff --git a/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal
new file mode 100644
index 00000000000..153a5b08af1
--- /dev/null
+++ b/cabal-testsuite/PackageTests/BuildCompilerSetup/client/client.cabal
@@ -0,0 +1,14 @@
+cabal-version: 2.0
+name: client
+version: 0.1.0.0
+build-type: Custom
+
+custom-setup
+ setup-depends:
+ base
+ , Cabal >= 2.0
+
+executable check-compiler
+ main-is: Main.hs
+ build-depends: base
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/DataDirSetupTest/test/DataDirTest.hs b/cabal-testsuite/PackageTests/DataDirSetupTest/test/DataDirTest.hs
index 1c5d14b7f0b..4eb54598363 100644
--- a/cabal-testsuite/PackageTests/DataDirSetupTest/test/DataDirTest.hs
+++ b/cabal-testsuite/PackageTests/DataDirSetupTest/test/DataDirTest.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
-import Control.Monad (when)
+import Control.Monad (unless)
import System.Directory (createDirectory, doesFileExist, getCurrentDirectory, setCurrentDirectory)
import System.Environment (getEnv)
import System.Exit (exitFailure, exitSuccess)
@@ -39,7 +39,7 @@ main = do
putStrLn $ "File exists after cd: " ++ show fileExistsAfterCd
-- Exit with error if we can't find the file
- when (not fileExistsAfterCd) $ do
+ unless fileExistsAfterCd $ do
hPutStrLn stderr "ERROR: Could not find data file after changing directory!"
hPutStrLn stderr $ "datadir_test_datadir was set to: " ++ dataDirEnv
exitFailure
diff --git a/cabal-testsuite/PackageTests/LibraryBytecodeUnsupported/cabal.out b/cabal-testsuite/PackageTests/LibraryBytecodeUnsupported/cabal.out
index 94a7d230add..a2308dc3485 100644
--- a/cabal-testsuite/PackageTests/LibraryBytecodeUnsupported/cabal.out
+++ b/cabal-testsuite/PackageTests/LibraryBytecodeUnsupported/cabal.out
@@ -1,9 +1,11 @@
# cabal v2-build
Resolving dependencies...
+Warning:
+ This compiler does not support bytecode libraries; ignoring --enable-library-bytecode
+ In the inplace package 'library-bytecode-unsupported-0.1'
Build profile: -w ghc- -O1
In order, the following will be built:
- library-bytecode-unsupported-0.1 (lib) (first run)
Configuring library for library-bytecode-unsupported-0.1...
-Warning: This compiler does not support bytecode libraries; ignoring --enable-library-bytecode
Preprocessing library for library-bytecode-unsupported-0.1...
Building library for library-bytecode-unsupported-0.1...
diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out
deleted file mode 100644
index c8c27376397..00000000000
--- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.out
+++ /dev/null
@@ -1,8 +0,0 @@
-# cabal v2-run
-Warning: The package description file ./script.cabal has warnings: script.cabal:0:0: A package using 'cabal-version: >=1.10' must use section syntax. See the Cabal user guide for details.
-Resolving dependencies...
-Build profile: -w ghc- -O1
-In order, the following will be built:
- - fake-package-0 (exe:script-script.lhs) (first run)
-Configuring executable 'script-script.lhs' for fake-package-0...
-Building executable 'script-script.lhs' for fake-package-0...
diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs
index 64c858e8d0d..e7ae8bfc4c6 100644
--- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs
+++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ScriptLiterate/cabal.test.hs
@@ -1,5 +1,5 @@
import Test.Cabal.Prelude
-main = cabalTest $ do
+main = cabalTest $ recordMode DoNotRecord $ do
res <- cabal' "v2-run" ["script.lhs"]
assertOutputContains "Hello World" res
diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.no-target.out b/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.no-target.out
new file mode 100644
index 00000000000..a7f6033bb1d
--- /dev/null
+++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.no-target.out
@@ -0,0 +1,12 @@
+# cabal run
+Resolving dependencies...
+Warning: Your RTS options are applied to cabal, not the executable. Use '--' to separate cabal options from your executable options. For example, use 'cabal run -- +RTS -N to pass the '-N' RTS option to your executable.
+Build profile: -w ghc- -O1
+In order, the following will be built:
+ - WarningRTS-1.0 (exe:foo) (first run)
+Configuring executable 'foo' for WarningRTS-1.0...
+Preprocessing executable 'foo' for WarningRTS-1.0...
+Building executable 'foo' for WarningRTS-1.0...
+# cabal run
+Warning: Your RTS options are applied to cabal, not the executable. Use '--' to separate cabal options from your executable options. For example, use 'cabal run -- +RTS -N to pass the '-N' RTS option to your executable.
+# cabal run
diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs
index 99b9f2008a2..39994589144 100644
--- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs
+++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/WarningRTS/cabal.test.hs
@@ -1,6 +1,7 @@
import Test.Cabal.Prelude
-main = cabalTest $ do
+main = do
+ cabalTest $ do
res <- cabal' "run" ["foo", "+RTS"]
assertOutputContains "Warning: Your RTS options" res
@@ -9,3 +10,16 @@ main = cabalTest $ do
res <- cabal' "run" ["foo", "--", "+RTS"]
assertOutputDoesNotContain "Warning: Your RTS options" res
+
+ -- Regression tests for https://github.com/haskell/cabal/issues/10487:
+ -- 'cabal run -- +RTS' should not fail with "Unrecognised target '+RTS'"
+ cabalTest' "no-target" $ do
+ res <- cabal' "run" ["+RTS"]
+ assertOutputContains "Warning: Your RTS options" res
+
+ res <- cabal' "run" ["+RTS", "--"]
+ assertOutputContains "Warning: Your RTS options" res
+
+ res <- cabal' "run" ["--", "+RTS"]
+ assertOutputDoesNotContain "Warning: Your RTS options" res
+ assertOutputDoesNotContain "Unrecognised target" res
diff --git a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.out b/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.out
deleted file mode 100644
index 53ccefe2347..00000000000
--- a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.out
+++ /dev/null
@@ -1,12 +0,0 @@
-# cabal build
-Resolving dependencies...
-Build profile: -w ghc- -O1
-In order, the following will be built:
- - aa-0.1.0.0 (exe:a) (first run)
-Configuring executable 'a' for aa-0.1.0.0...
-Warning: Executables will use dynamic linking, but a shared library is not
-being built. Linking will fail if any executables depend on the library.
-Error: [Cabal-3339]
-Operating system: windows, does not support shared executables
-Error: [Cabal-7125]
-Failed to build aa-0.1.0.0-inplace-a. The failure occurred during the configure step.
diff --git a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs b/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs
index aa0c8e83b7b..792f043165e 100644
--- a/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs
+++ b/cabal-testsuite/PackageTests/NoOSSupport/DynExe/cabal.test.hs
@@ -2,4 +2,7 @@ import Test.Cabal.Prelude
main = do
skipUnlessWindows
- cabalTest $ fails $ cabal "build" ["--enable-executable-dynamic", "--disable-shared"]
+ cabalTest $ recordMode DoNotRecord $ fails $ do
+ res <- cabal' "build" ["--enable-executable-dynamic", "--disable-shared"]
+ assertOutputContains "does not support shared executables" res
+
diff --git a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.out b/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.out
deleted file mode 100644
index f59d29e6b17..00000000000
--- a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.out
+++ /dev/null
@@ -1,10 +0,0 @@
-# cabal build
-Resolving dependencies...
-Build profile: -w ghc- -O1
-In order, the following will be built:
- - aa-0.1.0.0 (exe:a) (first run)
-Configuring executable 'a' for aa-0.1.0.0...
-Error: [Cabal-3339]
-Operating system: windows, does not support relocatable builds
-Error: [Cabal-7125]
-Failed to build aa-0.1.0.0-inplace-a. The failure occurred during the configure step.
diff --git a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs b/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs
index 448fc6fc22a..dc50d7b2ada 100644
--- a/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs
+++ b/cabal-testsuite/PackageTests/NoOSSupport/RelocatableExe/cabal.test.hs
@@ -2,4 +2,6 @@ import Test.Cabal.Prelude
main = do
skipUnlessWindows
- cabalTest $ fails $ cabal "build" ["--enable-relocatable"]
+ cabalTest $ recordMode DoNotRecord $ fails $ do
+ res <- cabal' "build" ["--enable-relocatable"]
+ assertOutputContains "windows, does not support relocatable builds" res
diff --git a/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out b/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out
index 1278857b31d..f6afdb5e560 100644
--- a/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out
+++ b/cabal-testsuite/PackageTests/Project/CoverageProject/cabal.out
@@ -5,11 +5,9 @@ In order, the following will be built:
- pkg-a-0.1 (lib) (first run)
- pkg-a-0.1 (test:testing) (first run)
Configuring library for pkg-a-0.1...
-Warning: [no-default-language] 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.
Preprocessing library for pkg-a-0.1...
Building library for pkg-a-0.1...
Configuring test suite 'testing' for pkg-a-0.1...
-Warning: [no-default-language] 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.
Preprocessing test suite 'testing' for pkg-a-0.1...
Building test suite 'testing' for pkg-a-0.1...
Running 1 test suites...
diff --git a/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal b/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal
index 4a064d3389c..c6c44432201 100644
--- a/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal
+++ b/cabal-testsuite/PackageTests/Project/CoverageProject/pkg-a/pkg-a.cabal
@@ -18,6 +18,7 @@ library
test-suite testing
type: exitcode-stdio-1.0
build-depends: base, pkg-a
+ default-language: Haskell2010
main-is: Main.hs
hs-source-dirs: test
diff --git a/cabal-testsuite/PackageTests/Regression/T5318/install.out b/cabal-testsuite/PackageTests/Regression/T5318/install.out
index 9c47fdc6b50..e69de29bb2d 100644
--- a/cabal-testsuite/PackageTests/Regression/T5318/install.out
+++ b/cabal-testsuite/PackageTests/Regression/T5318/install.out
@@ -1,8 +0,0 @@
-# cabal v1-install
-Resolving dependencies...
-Configuring empty-data-dir-0...
-Preprocessing executable 'foo' for empty-data-dir-0...
-Building executable 'foo' for empty-data-dir-0...
-Installing executable foo in
-Warning: The directory /install.dist/home/.cabal/bin is not in the system search path.
-Completed empty-data-dir-0
diff --git a/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs b/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs
index 6fd409c2704..3efaca5c05a 100644
--- a/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs
+++ b/cabal-testsuite/PackageTests/Regression/T5318/install.test.hs
@@ -1,3 +1,3 @@
import Test.Cabal.Prelude
-main = cabalTest $
+main = cabalTest $ recordMode DoNotRecord $
cabal "v1-install" []
diff --git a/cabal-testsuite/PackageTests/Regression/T6440/cabal.out b/cabal-testsuite/PackageTests/Regression/T6440/cabal.out
index 5c24cecf81f..23cfe47a187 100644
--- a/cabal-testsuite/PackageTests/Regression/T6440/cabal.out
+++ b/cabal-testsuite/PackageTests/Regression/T6440/cabal.out
@@ -6,15 +6,12 @@ In order, the following will be built:
- cabal6440-0.1 (lib) (first run)
- cabal6440-0.1 (test:tests) (first run)
Configuring library 'intern6440' for cabal6440-0.1...
-Warning: [no-default-language] 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.
Preprocessing library 'intern6440' for cabal6440-0.1...
Building library 'intern6440' for cabal6440-0.1...
Configuring library for cabal6440-0.1...
-Warning: [no-default-language] 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.
Preprocessing library for cabal6440-0.1...
Building library for cabal6440-0.1...
Configuring test suite 'tests' for cabal6440-0.1...
-Warning: [no-default-language] 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.
Preprocessing test suite 'tests' for cabal6440-0.1...
Building test suite 'tests' for cabal6440-0.1...
Running 1 test suites...
diff --git a/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal b/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal
index 42192a71672..1af78b1545b 100644
--- a/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal
+++ b/cabal-testsuite/PackageTests/Regression/T6440/cabal6440.cabal
@@ -13,7 +13,7 @@ library intern6440
exposed-modules: Inn
build-depends: base
hs-source-dirs: srcint
-
+ default-language: Haskell2010
test-suite tests
main-is: Main.hs
diff --git a/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out b/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out
index ebfae34dde9..49589c6e29d 100644
--- a/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out
+++ b/cabal-testsuite/PackageTests/Regression/T7234/Success/cabal.out
@@ -4,7 +4,6 @@ Resolving dependencies...
Build profile: -w ghc- -O1
In order, the following will be built:
- issue7234-0 (lib) (first run)
-Warning: issue7234.cabal:14:3: The field "other-extensions" is available only since the Cabal specification version 1.10.
Configuring library for issue7234-0...
Preprocessing library for issue7234-0...
Building library for issue7234-0...
diff --git a/cabal-testsuite/PackageTests/Regression/T9640/cabal.out b/cabal-testsuite/PackageTests/Regression/T9640/cabal.out
index a3d4d2935a4..c55ad4c9da4 100644
--- a/cabal-testsuite/PackageTests/Regression/T9640/cabal.out
+++ b/cabal-testsuite/PackageTests/Regression/T9640/cabal.out
@@ -11,7 +11,6 @@ Configuring one-custom-0.1.0.0...
Preprocessing library for one-custom-0.1.0.0...
Building library for one-custom-0.1.0.0...
Installing library in
-Warning: depend-on-custom-with-exe.cabal:16:1: Ignoring trailing fields after sections: "ghc-options"
Configuring library for depend-on-custom-with-exe-0.1.0.0...
Preprocessing library for depend-on-custom-with-exe-0.1.0.0...
Building library for depend-on-custom-with-exe-0.1.0.0...
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP
new file mode 100644
index 00000000000..442abf888c7
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP
@@ -0,0 +1 @@
+a = True
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP
new file mode 100644
index 00000000000..72b3e397d8b
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP
@@ -0,0 +1 @@
+b = False
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP
new file mode 100644
index 00000000000..e18e4f45023
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP
@@ -0,0 +1 @@
+c = 'x'
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs
new file mode 100644
index 00000000000..bfa0675fc95
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import Distribution.Simple ( defaultMainWithSetupHooks )
+import SetupHooks ( setupHooks )
+
+main :: IO ()
+main = defaultMainWithSetupHooks setupHooks
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs
new file mode 100644
index 00000000000..59f68797f60
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StaticPointers #-}
+
+module SetupHooks where
+
+-- Cabal
+import Distribution.Compat.Binary
+import Distribution.Parsec
+ ( simpleParsec )
+import Distribution.Simple.LocalBuildInfo
+ ( interpretSymbolicPathLBI )
+import Distribution.Simple.Utils
+ ( warn, rewriteFileEx )
+import Distribution.Utils.Path
+import Distribution.Verbosity
+
+-- Cabal-hooks
+import Distribution.Simple.SetupHooks
+
+-- base
+import Control.Monad.IO.Class
+ ( liftIO )
+import Data.Foldable
+ ( for_ )
+import Data.List
+ ( isSuffixOf )
+import qualified Data.List.NonEmpty as NE
+ ( NonEmpty(..) )
+import Data.String
+ ( fromString )
+import GHC.Generics
+
+-- directory
+import System.Directory
+ ( listDirectory )
+
+-- filepath
+import System.FilePath
+ ( dropExtension )
+
+--------------------------------------------------------------------------------
+
+setupHooks :: SetupHooks
+setupHooks =
+ noSetupHooks
+ { buildHooks =
+ noBuildHooks
+ { preBuildComponentRules = Just $ rules (static ()) preBuildRules
+ }
+ }
+
+preBuildRules :: PreBuildComponentInputs -> RulesM ()
+preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do
+ let verbosityFlags = buildingWhatVerbosity what
+ clbi = targetCLBI tgt
+ autogenDir = autogenComponentModulesDir lbi clbi
+ srcDir = sameDirectory
+
+ -- Monitor .myPP files in the package directory.
+ let myPPGlob =
+ case simpleParsec "*.myPP" of
+ Just g -> g
+ Nothing -> error "SetupHooksRecompRules: failed to parse *.myPP glob"
+ addRuleMonitors [ monitorFileGlobExistence myPPGlob ]
+
+ -- Scan the package directory for .myPP files and register one
+ -- preprocessing rule per file.
+ allFiles <- liftIO $ listDirectory (interpretSymbolicPathLBI lbi srcDir)
+ for_ (filter (".myPP" `isSuffixOf`) allFiles) $ \fileName -> do
+ let baseName = dropExtension fileName
+ -- For A and B, bake in a constant verbosity so that their rules are
+ -- unaffected by the --verbose flag. C uses the actual verbosity, so
+ -- its rule changes when the verbosity changes.
+ ruleVerbosityFlags
+ | baseName `elem` ["A", "B"] = normal
+ | otherwise = verbosityFlags
+ registerRule_ (fromString $ "myPP " ++ baseName) $
+ staticRule
+ (mkCommand (static Dict) (static runMyPP) $
+ MyPPInput
+ { ppVerbosityFlags = ruleVerbosityFlags
+ , ppSrcDir = srcDir
+ , ppAutogenDir = autogenDir
+ , ppBaseName = baseName
+ })
+ [ FileDependency $ Location srcDir (makeRelativePathEx fileName) ]
+ ( Location autogenDir (makeRelativePathEx baseName <.> "hs") NE.:| [] )
+
+-- | Preprocess a single .myPP file into a .hs module.
+runMyPP :: MyPPInput -> IO ()
+runMyPP (MyPPInput {..}) = do
+ let verbosity = mkVerbosity defaultVerbosityHandles ppVerbosityFlags
+ warn verbosity $ "Running myPP preprocessor for " ++ ppBaseName
+ content <- readFile (getSymbolicPath ppSrcDir ppBaseName <.> "myPP")
+ rewriteFileEx verbosity (getSymbolicPath ppAutogenDir ppBaseName <.> "hs") $
+ "module " ++ ppBaseName ++ " where\n" ++ content
+
+data MyPPInput
+ = MyPPInput
+ { ppVerbosityFlags :: VerbosityFlags
+ , ppSrcDir :: SymbolicPath Pkg (Dir Source)
+ , ppAutogenDir :: SymbolicPath Pkg (Dir Source)
+ , ppBaseName :: String
+ }
+ deriving stock ( Show, Generic )
+ deriving anyclass Binary
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal
new file mode 100644
index 00000000000..2482faa3607
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal
@@ -0,0 +1,28 @@
+cabal-version: 3.14
+name: setup-hooks-recomp-rules-test
+version: 0.1.0.0
+synopsis: Test recompilation checking for pre-build rules
+license: BSD-3-Clause
+author: NA
+maintainer: NA
+category: Testing
+build-type: Hooks
+
+custom-setup
+ setup-depends:
+ Cabal
+ , Cabal-hooks
+
+ , base
+ , filepath
+ , directory
+
+library
+ autogen-modules:
+ A, B, C
+ exposed-modules:
+ A, B, C
+ build-depends:
+ base
+ default-language:
+ Haskell2010
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs
new file mode 100644
index 00000000000..ea2ad7365a1
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs
@@ -0,0 +1,27 @@
+import Test.Cabal.Prelude
+
+main :: IO ()
+main = setupTest $ recordMode DoNotRecord $ do
+ setup "configure" []
+
+ -- First build: should run rules for A, B and C.
+ build1 <- setup' "build" ["--verbose=1"]
+ assertOutputContains "Running myPP preprocessor for A" build1
+ assertOutputContains "Running myPP preprocessor for B" build1
+ assertOutputContains "Running myPP preprocessor for C" build1
+
+ -- Modify A.myPP, leaving other files alone.
+ writeSourceFile "A.myPP" "a = 42\n"
+
+ -- Check we only re-run the preprocessor for A (file dependency changed).
+ build2 <- setup' "build" ["--verbose=1"]
+ assertOutputContains "Running myPP preprocessor for A" build2
+ assertOutputDoesNotContain "Running myPP preprocessor for B" build2
+ assertOutputDoesNotContain "Running myPP preprocessor for C" build2
+
+ -- Change verbosity. C's rule stores the actual verbosity, while A and B
+ -- bake in a constant verbosity. Thus we should only re-run the rule for C.
+ build3 <- setup' "build" ["--verbose=2"]
+ assertOutputDoesNotContain "Running myPP preprocessor for A" build3
+ assertOutputDoesNotContain "Running myPP preprocessor for B" build3
+ assertOutputContains "Running myPP preprocessor for C" build3
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs
new file mode 100644
index 00000000000..ab5e0c64ba6
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooks.hs
@@ -0,0 +1,6 @@
+module SetupHooks where
+
+import Distribution.Simple.SetupHooks
+
+setupHooks = noSetupHooks
+
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal
new file mode 100644
index 00000000000..f469abdb9e2
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/SetupHooksRecompilation.cabal
@@ -0,0 +1,17 @@
+cabal-version: 3.14
+name: SetupHooksRecompilation
+version: 0.1.0.0
+license: NONE
+author: Rodrigo Mesquita
+maintainer: rodrigo.m.mesquita@gmail.com
+build-type: Hooks
+extra-doc-files: CHANGELOG.md
+
+custom-setup
+ setup-depends: base, Cabal, Cabal-syntax, Cabal-hooks
+
+library
+ exposed-modules: MyLib
+ build-depends: base >= 4.12 && < 5.0
+ hs-source-dirs: src
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project
new file mode 100644
index 00000000000..e6fdbadb439
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs
new file mode 100644
index 00000000000..d91478dc30d
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/cabal.test.hs
@@ -0,0 +1,17 @@
+import Test.Cabal.Prelude
+
+import System.Directory ( doesFileExist )
+
+main = cabalTest $ do
+ env <- getTestEnv
+ case testPackageDbPath env of
+ Nothing -> skip "Cabal-hooks library unavailable."
+ Just _pkgdb -> recordMode DoNotRecord $ do
+ cabal "v2-build" []
+ let setupHooksPath = testCurrentDir env "SetupHooks.hs"
+ setupHooksExists <- liftIO $ doesFileExist setupHooksPath
+ unless setupHooksExists $
+ error "Broken test: tried to write to a SetupHooks.hs file that doesn't exist."
+ liftIO $ appendFile setupHooksPath "this should fail to compile!"
+ -- If this doesn't fail, it's because we didn't re-build.
+ fails $ cabal "v2-build" []
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs
new file mode 100644
index 00000000000..e657c4403f6
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompilation/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/Setup.hs
new file mode 100644
index 00000000000..c095e2ccaf8
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/Setup.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import Distribution.Simple (defaultMainWithSetupHooks)
+import SetupHooks (setupHooks)
+
+main :: IO ()
+main = defaultMainWithSetupHooks setupHooks
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/SetupHooks.hs
new file mode 100644
index 00000000000..368d263436b
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/SetupHooks.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StaticPointers #-}
+
+module SetupHooks where
+
+import Control.Monad (forM_)
+import Control.Monad.IO.Class (liftIO)
+import Distribution.CabalSpecVersion
+import Distribution.Compat.Binary
+import Distribution.Simple.Glob
+import Distribution.Simple.LocalBuildInfo (componentBuildInfo, mbWorkDirLBI)
+import Distribution.Simple.SetupHooks
+import Distribution.Simple.Utils
+import Distribution.Utils.Path
+import Distribution.Utils.ShortText (toShortText)
+import Distribution.Verbosity
+
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.Traversable (for)
+import GHC.Generics
+import System.FilePath
+
+setupHooks :: SetupHooks
+setupHooks =
+ noSetupHooks
+ { buildHooks =
+ noBuildHooks
+ { preBuildComponentRules = Just $ rules (static ()) preBuildRules
+ }
+ }
+
+data PPArgs
+ = PPArgs
+ { verbosityFlags :: VerbosityFlags
+ , srcPath :: FilePath
+ , dstPath :: FilePath
+ }
+ deriving stock (Show, Generic)
+ deriving anyclass (Binary)
+
+-- Register a pre-build rule that uses a recursive glob.
+preBuildRules :: PreBuildComponentInputs -> RulesM ()
+preBuildRules PreBuildComponentInputs{..} = do
+ let cabalVersion = CabalSpecV3_16
+ verbosityFlags = buildingWhatVerbosity buildingWhat
+ comp = targetComponent targetInfo
+ bi = componentBuildInfo comp
+ mbWorkDir = mbWorkDirLBI localBuildInfo
+ clbi = targetCLBI targetInfo
+ autogenDir = autogenComponentModulesDir localBuildInfo clbi
+ -- buildDir = componentBuildDir localBuildInfo clbi
+
+ let globFilename = "**/*.ppExt"
+ let glob = case parseFileGlob cabalVersion globFilename of
+ Left err ->
+ error $ explainGlobSyntaxError globFilename err
+ Right glob ->
+ glob
+ myPpFiles <- fmap concat $ liftIO $ for (hsSourceDirs bi) $ \srcDir -> do
+ let root = interpretSymbolicPath mbWorkDir srcDir
+ let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags
+ matches <- runDirFileGlob verbosity Nothing root glob
+ return
+ [ Location srcDir (makeRelativePathEx match)
+ | match <- globMatches matches
+ ]
+ -- Monitor existence of file glob to handle new input files getting added.
+ addRuleMonitors [monitorFileGlobExistence $ RootedGlob FilePathRelative glob]
+
+ let preprocessFile PPArgs{..} = do
+ let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags
+ warn verbosity $ "Preprocessing: " ++ normalise srcPath ++ " -> " ++ normalise dstPath
+ (modLine : inputLines) <- lines <$> readFile srcPath
+ let hsSrc =
+ unlines
+ [ modLine
+ , ""
+ , "str :: String"
+ , "str = " ++ show (unlines inputLines)
+ ]
+ createDirectoryIfMissingVerbose verbosity True (takeDirectory dstPath)
+ rewriteFileEx verbosity dstPath hsSrc
+
+ -- Register preprocessor rules
+ forM_ myPpFiles $ \ppFile@(Location _ relPath) -> do
+ let verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags
+ let ppFile' =
+ Location
+ autogenDir
+ (replaceExtensionSymbolicPath (unsafeCoerceSymbolicPath relPath) "hs")
+
+ let action =
+ mkCommand
+ (static Dict)
+ (static preprocessFile)
+ PPArgs
+ { srcPath = interpretSymbolicPath mbWorkDir (location ppFile)
+ , dstPath = interpretSymbolicPath mbWorkDir (location ppFile')
+ , ..
+ }
+
+ registerRule ("myPP " <> toShortText (getSymbolicPath relPath)) $
+ staticRule
+ action
+ [FileDependency ppFile]
+ (ppFile' :| [])
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/cabal.project
new file mode 100644
index 00000000000..e6fdbadb439
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup-hooks-recursive-glob-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup-hooks-recursive-glob-test.cabal
new file mode 100644
index 00000000000..8c71191f5fa
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup-hooks-recursive-glob-test.cabal
@@ -0,0 +1,20 @@
+cabal-version: 3.14
+name: setup-hooks-recursive-glob-test
+version: 0.1.0.0
+synopsis: Test that recursive globs as supported in setup hooks
+license: BSD-3-Clause
+author: NA
+maintainer: NA
+category: Testing
+build-type: Hooks
+extra-source-files: src/**/*.ppExt
+
+custom-setup
+ setup-depends: Cabal, Cabal-hooks, base, filepath
+
+library
+ exposed-modules: A, Foo.B
+ autogen-modules: A, Foo.B
+ hs-source-dirs: src
+ build-depends: base
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup.out
new file mode 100644
index 00000000000..16c487863bb
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup.out
@@ -0,0 +1,11 @@
+# Setup configure
+Configuring setup-hooks-recursive-glob-test-0.1.0.0...
+# Setup build
+Warning: Preprocessing: src/Foo/B.ppExt -> setup.dist/work/dist/build/autogen/Foo/B.hs
+Warning: Preprocessing: src/A.ppExt -> setup.dist/work/dist/build/autogen/A.hs
+Preprocessing library for setup-hooks-recursive-glob-test-0.1.0.0...
+Building library for setup-hooks-recursive-glob-test-0.1.0.0...
+# Setup build
+Warning: Preprocessing: src/Foo/B.ppExt -> setup.dist/work/dist/build/autogen/Foo/B.hs
+Preprocessing library for setup-hooks-recursive-glob-test-0.1.0.0...
+Building library for setup-hooks-recursive-glob-test-0.1.0.0...
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup.test.hs
new file mode 100644
index 00000000000..fa617f1f4ca
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/setup.test.hs
@@ -0,0 +1,10 @@
+import Test.Cabal.Prelude
+
+main =
+ setupTest $ do
+ setup "configure" []
+ setup "build" []
+ -- Modify one file in the temp copy (testCurrentDir) and rebuild; only
+ -- the preprocessor rule for Foo.B should re-run, not the one for A.
+ writeSourceFile "src/Foo/B.ppExt" "module Foo.B where\nModified text"
+ setup "build" []
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/src/A.ppExt b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/src/A.ppExt
new file mode 100644
index 00000000000..b2ce2e10dc6
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/src/A.ppExt
@@ -0,0 +1,2 @@
+module A where
+This is module A
diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/src/Foo/B.ppExt b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/src/Foo/B.ppExt
new file mode 100644
index 00000000000..117f276977e
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecursiveGlob/src/Foo/B.ppExt
@@ -0,0 +1,2 @@
+module Foo.B where
+Original text
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-bad/Cabal.cabal b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-bad/Cabal.cabal
new file mode 100644
index 00000000000..ec688149ce8
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-bad/Cabal.cabal
@@ -0,0 +1,6 @@
+cabal-version: 2.4
+name: Cabal
+version: 3.16.666.0
+library
+ default-language: Haskell2010
+ build-depends: stub == 0.1
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/Cabal.cabal b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/Cabal.cabal
new file mode 100644
index 00000000000..db58ead48f1
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/Cabal.cabal
@@ -0,0 +1,10 @@
+cabal-version: 2.4
+name: Cabal
+version: 3.16.777.0
+library
+ default-language: Haskell2010
+ build-depends: base, stub == 0.2
+ exposed-modules:
+ Distribution.Simple.SetupHooks
+ Distribution.Simple
+ hs-source-dirs: src
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/src/Distribution/Simple.hs b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/src/Distribution/Simple.hs
new file mode 100644
index 00000000000..bb0f980f9c4
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/src/Distribution/Simple.hs
@@ -0,0 +1,13 @@
+module Distribution.Simple ( defaultMainWithSetupHooks ) where
+
+import System.Exit ( exitFailure )
+import Distribution.Simple.SetupHooks ( SetupHooks )
+
+defaultMainWithSetupHooks :: SetupHooks -> IO ()
+defaultMainWithSetupHooks _ = do
+ putStrLn "Chosen GOOD Cabal"
+ exitFailure
+ -- NB: we call 'exitFailure' here so that cabal-install, who is invoking
+ -- this code thinking it is building the package, doesn't try to proceed
+ -- when actually we haven't done anything (e.g. try to read a package
+ -- description file).
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/src/Distribution/Simple/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/src/Distribution/Simple/SetupHooks.hs
new file mode 100644
index 00000000000..e18a8322d61
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/Cabal-good/src/Distribution/Simple/SetupHooks.hs
@@ -0,0 +1,3 @@
+module Distribution.Simple.SetupHooks where
+
+data SetupHooks = SetupHooks
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/T11331/Setup.hs
new file mode 100644
index 00000000000..bac512e3101
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/Setup.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Main where
+
+-- Cabal
+import Distribution.Simple ( defaultMainWithSetupHooks )
+
+-- T11331
+import SetupHooks ( setupHooks )
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMainWithSetupHooks setupHooks
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/T11331/SetupHooks.hs
new file mode 100644
index 00000000000..17fa0471143
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/SetupHooks.hs
@@ -0,0 +1,4 @@
+module SetupHooks (setupHooks) where
+
+-- fancy-hooks
+import FancyHooks (setupHooks)
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/T11331.cabal b/cabal-testsuite/PackageTests/SetupHooks/T11331/T11331.cabal
new file mode 100644
index 00000000000..d7250ee8d24
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/T11331.cabal
@@ -0,0 +1,18 @@
+cabal-version: 3.14
+name: T11331
+version: 0.1.0.0
+synopsis: Test for Cabal bug 11331
+license: BSD-3-Clause
+author: NA
+maintainer: NA
+category: Testing
+build-type: Hooks
+
+custom-setup
+ setup-depends: fancy-hooks
+
+library
+ default-language: Haskell2010
+ build-depends: stub == 0.1
+
+-- See cabal.test.hs for explanation of this test.
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/T11331/cabal.project
new file mode 100644
index 00000000000..e6fdbadb439
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/cabal.test.hs b/cabal-testsuite/PackageTests/SetupHooks/T11331/cabal.test.hs
new file mode 100644
index 00000000000..df19ce90b90
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/cabal.test.hs
@@ -0,0 +1,56 @@
+import Test.Cabal.Prelude
+
+{- Test for https://github.com/haskell/cabal/issues/11331
+
+This test works by having a package database with two Cabal libraries in it,
+a good one (Cabal-good) and a poisoned one (Cabal-bad).
+
+Cabal-good depends on stub == 0.2 and Cabal-bad depends on stub == 0.1.
+
+Moreover, we have a fancy-hooks package in the package database, that has been
+built against Cabal-good.
+
+T11331 has the following Cabal file:
+
+ T11331.setup --> fancy-hooks
+ T11331.lib --> stub == 0.1
+
+The test checks that, for the setup component, we correctly use Cabal-good
+and not Cabal-bad, as only Cabal-good is compatible with fancy-hooks (correct
+ABI hash of Cabal dependency).
+-}
+main :: IO ()
+main = cabalTest $ recordMode DoNotRecord $ withPackageDb $ do
+ -- Build good package set 'fancy-hooks -> Cabal-good -> stub-0.2' first.
+ withDirectory "stub-0.2" $ do
+ setup "configure" []
+ setup "build" []
+ setup "register" ["--inplace"]
+ withDirectory "Cabal-good" $ do
+ setup "configure" []
+ setup "build" []
+ setup "register" ["--inplace"]
+ withDirectory "fancy-hooks" $ do
+ setup "configure" []
+ setup "build" []
+ setup "register" ["--inplace"]
+
+ -- Now build bad package set 'Cabal-bad -> stub-0.1'.
+ withDirectory "stub-0.1" $ do
+ setup "configure" []
+ setup "build" []
+ setup "register" ["--inplace"]
+ withDirectory "Cabal-bad" $ do
+ setup "configure" []
+ setup "build" []
+ setup "register" ["--inplace"]
+
+ -- Now try to build 'T11331' with cabal-install, using the package database
+ -- that we carefully crafted above. This tests that cabal-install picks
+ -- 'Cabal-good' for the setup component of 'T11331', otherwise we will fail.
+ dbDir <- testPackageDbDir <$> getTestEnv
+
+ -- This fails because the fake Cabal-good defaultMain doesn't do anything
+ -- except print "Chosen GOOD Cabal".
+ res <- fails $ cabal' "build" [ "--package-db=" ++ dbDir, "T11331" ]
+ assertOutputContains "Chosen GOOD Cabal" res
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/fancy-hooks/fancy-hooks.cabal b/cabal-testsuite/PackageTests/SetupHooks/T11331/fancy-hooks/fancy-hooks.cabal
new file mode 100644
index 00000000000..0b2459b0fc4
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/fancy-hooks/fancy-hooks.cabal
@@ -0,0 +1,8 @@
+cabal-version: 2.4
+name: fancy-hooks
+version: 1.0
+library
+ default-language: Haskell2010
+ build-depends: Cabal
+ exposed-modules: FancyHooks
+ hs-source-dirs: src
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/fancy-hooks/src/FancyHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/T11331/fancy-hooks/src/FancyHooks.hs
new file mode 100644
index 00000000000..0a2f1373da7
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/fancy-hooks/src/FancyHooks.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module FancyHooks ( setupHooks ) where
+
+import Distribution.Simple.SetupHooks ( SetupHooks(..) )
+
+setupHooks :: SetupHooks
+setupHooks = SetupHooks
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/stub-0.1/stub.cabal b/cabal-testsuite/PackageTests/SetupHooks/T11331/stub-0.1/stub.cabal
new file mode 100644
index 00000000000..bdc9191fdb6
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/stub-0.1/stub.cabal
@@ -0,0 +1,5 @@
+cabal-version: 2.4
+name: stub
+version: 0.1
+library
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/SetupHooks/T11331/stub-0.2/stub.cabal b/cabal-testsuite/PackageTests/SetupHooks/T11331/stub-0.2/stub.cabal
new file mode 100644
index 00000000000..7f8e75f395a
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupHooks/T11331/stub-0.2/stub.cabal
@@ -0,0 +1,5 @@
+cabal-version: 2.4
+name: stub
+version: 0.2
+library
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs
index 11d28d8d7cb..1fe6f63683a 100644
--- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs
+++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs
@@ -7,6 +7,6 @@ import Control.Monad
main :: IO ()
main | fooTest [] = do
-- Make sure that the output buffer is drained
- replicateM 10000 $ putStrLn "The quick brown fox jumps over the lazy dog"
+ replicateM_ 10000 $ putStrLn "The quick brown fox jumps over the lazy dog"
exitSuccess
| otherwise = exitFailure
diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs
index ce578114cd1..9897f5b5cab 100644
--- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs
+++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs
@@ -6,6 +6,6 @@ import Control.Monad
main :: IO ()
main | fooTest [] = do
- replicateM 5 $ putStrLn "The quick brown fox jumps over the lazy dog"
+ replicateM_ 5 $ putStrLn "The quick brown fox jumps over the lazy dog"
exitSuccess
| otherwise = exitFailure
diff --git a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs
index 71c584120f5..38fd325f126 100644
--- a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs
+++ b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.test.hs
@@ -4,7 +4,7 @@ import System.FilePath (())
main = do
-- Test that --with-repl works with a valid GHC path
- cabalTest' "with-repl-valid-path" $ do
+ cabalTest' "with-repl-valid-path" $ recordMode DoNotRecord $ do
cabal' "clean" []
-- Get the path to the system GHC
ghc_prog <- requireProgramM ghcProgram
@@ -13,7 +13,7 @@ main = do
assertOutputContains "GHCi, version" res
-- Test that --with-repl fails with an invalid path
- cabalTest' "with-repl-invalid-path" $ do
+ cabalTest' "with-repl-invalid-path" $ recordMode DoNotRecord $ do
cabal' "clean" []
res <- fails $ cabalWithStdin "v2-repl" ["--with-repl=/nonexistent/path/to/ghc"] ""
assertOutputContains "does not exist" res
diff --git a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-invalid-path.out b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-invalid-path.out
deleted file mode 100644
index b59b62a074a..00000000000
--- a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-invalid-path.out
+++ /dev/null
@@ -1,10 +0,0 @@
-# cabal clean
-# cabal v2-repl
-Resolving dependencies...
-Build profile: -w ghc- -O1
-In order, the following will be built:
- - cabal-with-repl-0.1.0.0 (interactive) (lib) (first run)
-Configuring library for cabal-with-repl-0.1.0.0...
-Preprocessing library for cabal-with-repl-0.1.0.0...
-Error: [Cabal-7125]
-repl failed for cabal-with-repl-0.1.0.0-inplace.
diff --git a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-valid-path.out b/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-valid-path.out
deleted file mode 100644
index f1ca1ffc808..00000000000
--- a/cabal-testsuite/PackageTests/WithRepl/SimpleTests/cabal.with-repl-valid-path.out
+++ /dev/null
@@ -1,8 +0,0 @@
-# cabal clean
-# cabal v2-repl
-Resolving dependencies...
-Build profile: -w ghc- -O1
-In order, the following will be built:
- - cabal-with-repl-0.1.0.0 (interactive) (lib) (first run)
-Configuring library for cabal-with-repl-0.1.0.0...
-Preprocessing library for cabal-with-repl-0.1.0.0...
diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs
index 49b2c80c6bf..6f90145c575 100644
--- a/cabal-testsuite/main/cabal-tests.hs
+++ b/cabal-testsuite/main/cabal-tests.hs
@@ -159,7 +159,7 @@ buildCabalLibsProject projString verb mbGhc dir = do
, "--project-file=" ++ dir "cabal.project-test"
, "build"
, "-w", programPath ghc
- , "Cabal", "Cabal-syntax", "Cabal-hooks"
+ , "Cabal", "Cabal-syntax", "Cabal-hooks", "hooks-exe"
] ) { progInvokeCwd = Just dir })
-- Determine the path to the packagedb in the store for this ghc version
@@ -192,7 +192,8 @@ buildCabalLibsSpecific ver verb mbGhc builddir_rel = do
buildCabalLibsIntree :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath]
buildCabalLibsIntree root verb mbGhc builddir_rel = do
dir <- canonicalizePath (builddir_rel "intree")
- buildCabalLibsProject ("packages: " ++ root "Cabal" ++ " " ++ root "Cabal-syntax" ++ " " ++ root "Cabal-hooks") verb mbGhc dir
+ let libs = [ "Cabal", "Cabal-syntax", "Cabal-hooks", "hooks-exe" ]
+ buildCabalLibsProject ("packages: " ++ unwords ( map ( root ) libs ) ) verb mbGhc dir
main :: IO ()
main = do
diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs
index 4fa81e2e069..47920a1a9e4 100644
--- a/cabal-testsuite/src/Test/Cabal/Monad.hs
+++ b/cabal-testsuite/src/Test/Cabal/Monad.hs
@@ -7,6 +7,7 @@ module Test.Cabal.Monad
, setupTest
, cabalTest
, cabalTest'
+ , withBuildCompiler
-- * The monad
, TestM
@@ -127,6 +128,7 @@ import Test.Cabal.Run
data CommonArgs = CommonArgs
{ argCabalInstallPath :: Maybe FilePath
, argGhcPath :: Maybe FilePath
+ , argBuildCompilerPath :: Maybe FilePath
, argHackageRepoToolPath :: Maybe FilePath
, argHaddockPath :: Maybe FilePath
, argKeepTmpFiles :: Bool
@@ -154,6 +156,14 @@ commonArgParser =
<> metavar "PATH"
)
)
+ <*> optional
+ ( option
+ str
+ ( help "Path to the build compiler (cross-compile build stage). If omitted, tests requiring a separate build compiler are skipped."
+ <> long "with-build-compiler"
+ <> metavar "PATH"
+ )
+ )
<*> optional
( option
str
@@ -184,6 +194,7 @@ renderCommonArgs :: CommonArgs -> [String]
renderCommonArgs args =
maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args)
++ maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args)
+ ++ maybe [] (\x -> ["--with-build-compiler", x]) (argBuildCompilerPath args)
++ maybe [] (\x -> ["--with-haddock", x]) (argHaddockPath args)
++ maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args)
++ ["--accept" | argAccept args]
@@ -329,6 +340,15 @@ cabalTest' mode m = runTestM mode $ do
skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram
withReaderT (\nenv -> nenv{testCabalInstallAsSetup = True}) m
+-- | Run a test only when @--with-build-compiler@ was supplied, passing the
+-- build-compiler path to the action. Skips the test otherwise.
+withBuildCompiler :: (FilePath -> TestM ()) -> TestM ()
+withBuildCompiler f = do
+ env <- getTestEnv
+ case testBuildCompilerPath env of
+ Nothing -> skip "no build compiler (pass --with-build-compiler)"
+ Just p -> f p
+
type TestM = ReaderT TestEnv IO
gitProgram :: Program
@@ -444,6 +464,7 @@ runTestM mode m =
, testSetupPath = dist_dir "build" "setup" "setup"
, testPackageDbPath = case testArgPackageDb args of [] -> Nothing; xs -> Just xs
, testSkipSetupTests = argSkipSetupTests (testCommonArgs args)
+ , testBuildCompilerPath = argBuildCompilerPath cargs
, testHaveCabalShared = runnerWithSharedLib senv
, testEnvironment =
-- Use UTF-8 output on all platforms.
@@ -859,6 +880,8 @@ data TestEnv = TestEnv
-- use when compiling custom setups, plus the store with possible dependencies of those setup packages.
, testSkipSetupTests :: Bool
-- ^ Skip Setup tests?
+ , testBuildCompilerPath :: Maybe FilePath
+ -- ^ Path to the build compiler for cross-compile tests; 'Nothing' means skip such tests.
, testHaveCabalShared :: Bool
-- ^ Do we have shared libraries for the Cabal-under-tests?
-- This is used for example to determine whether we can build
diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs
index 2617d945d03..94757a77841 100644
--- a/cabal-testsuite/src/Test/Cabal/Prelude.hs
+++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs
@@ -1394,7 +1394,7 @@ withShorterPathForNewBuildStore test =
withTestDir
(mkVerbosity defaultVerbosityHandles normal)
"cabal-test-store"
- (\f -> withStoreDir f test)
+ (`withStoreDir` test)
-- | Find where a package locates in the store dir. This works only if there is exactly one 1 ghc version
-- and exactly 1 directory for the given package in the store dir.
diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs
index 4c502904de5..87425a7575d 100644
--- a/cabal-validate/src/Cli.hs
+++ b/cabal-validate/src/Cli.hs
@@ -245,8 +245,8 @@ resolveOpts opts = do
maybe
-- If neither `--hide-successes` or `--no-hide-successes` was given, then
-- only `--hide-successes` if `--quiet` is given.
- (optional (rawVerbosity opts <= Quiet) "--hide-successes")
- (\hideSuccesses -> optional hideSuccesses "--hide-successes")
+ ((rawVerbosity opts <= Quiet) `optional` "--hide-successes")
+ (`optional` "--hide-successes")
(rawTastyHideSuccesses opts)
++ maybe
[]
diff --git a/cabal.bootstrap.project b/cabal.bootstrap.project
index 5aa329f9ae5..7f7efa4fa32 100644
--- a/cabal.bootstrap.project
+++ b/cabal.bootstrap.project
@@ -6,6 +6,7 @@ packages:
, Cabal-hooks
, cabal-install
, cabal-install-solver
+ , hooks-exe
-- Don't include tests or benchmarks for bootstrapping
tests: False
diff --git a/changelog.d/11630.md b/changelog.d/11630.md
new file mode 100644
index 00000000000..9cb4dd91ccf
--- /dev/null
+++ b/changelog.d/11630.md
@@ -0,0 +1,7 @@
+---
+synopsis: Drop support for anything below GHC 8.0.0, base 4.9.0.0, Cabal 1.24.0.0
+packages: [cabal-install-solver, cabal-install, Cabal-syntax, Cabal]
+prs: 11630
+---
+Drop support for anything below GHC 8.0.0, base 4.9.0.0, Cabal 1.24.0.0
+These versions were no longer tested and likely non-functional.
diff --git a/changelog.d/11710.md b/changelog.d/11710.md
new file mode 100644
index 00000000000..30ba2c9f021
--- /dev/null
+++ b/changelog.d/11710.md
@@ -0,0 +1,8 @@
+---
+synopsis: "Remove legacy support for GHC < 7.6"
+packages: [Cabal, cabal-install]
+prs: 11710
+---
+Removed compatibility logic for GHC versions prior to 7.6. This simplifies
+package database stack handling and unifies the flag generation logic in
+`Distribution.Simple.GHC` and `Distribution.Simple.Program.GHC`.
diff --git a/changelog.d/hooks-recomp.md b/changelog.d/hooks-recomp.md
new file mode 100644
index 00000000000..48e757d86d9
--- /dev/null
+++ b/changelog.d/hooks-recomp.md
@@ -0,0 +1,22 @@
+---
+synopsis: Recompilation checking for SetupHooks pre-build rules
+packages: [Cabal, Cabal-hooks]
+prs: 11731
+issues: 11730
+---
+
+Pre-build rules are now only re-run when stale, according to the conditions
+described in the [SetupHooks API](https://hackage.haskell.org/package/Cabal-hooks/docs/Distribution-Simple-SetupHooks.html). That is, a rule is re-run if any of the following conditions are
+satisfied:
+
+ - The rule is new, or
+ - A dependency of the rule is stale.
+ That is, either we have re-run another rule that this rule depends on,
+ or one of the file inputs to the rule is newer than the oldest output of the
+ rule (or the rule output doesn't exist at all), or
+ - The rule itself has changed, e.g. the parameters stored in `RuleData`
+ have changed.
+
+In particular, Cabal will now write per-component caches of pre-build rules
+in order to compute which rules have changed between runs, with file name
+"setup-hooks-rules.cache".
diff --git a/changelog.d/hsec-2026-0006 b/changelog.d/hsec-2026-0006
new file mode 100644
index 00000000000..370384da47b
--- /dev/null
+++ b/changelog.d/hsec-2026-0006
@@ -0,0 +1,15 @@
+---
+synopsis: don't delete duplicate C header files
+packages: [Cabal]
+prs: 11733
+issues: 11176
+significance: significant
+---
+
+PR 4874 introduced a change which removes C headers that duplicate `autogen-includes`.
+This is unacceptable behavior, and in addition can be exploited on Windows to remove
+any file on the system. Issue a warning about undefined C compiler behavior instead.
+
+Original PR: https://github.com/haskell/cabal/pull/4874/changes#diff-e3cd8c042e1d9d4f3d54c4ec03a508cc2e61598aa7f88033d1cf847e5b712647R1658
+
+Security advisory for arbitrary file removal: https://haskell.github.io/security-advisories/advisory/HSEC-2026-0006.html
diff --git a/changelog.d/in-library.md b/changelog.d/in-library.md
new file mode 100644
index 00000000000..3ddee626042
--- /dev/null
+++ b/changelog.d/in-library.md
@@ -0,0 +1,28 @@
+---
+synopsis: Directly call in-library functions to build packages
+packages: [Cabal, cabal-install]
+prs: 11703
+significance: significant
+---
+
+The way `cabal-install` builds packages has been significantly overhauled. In
+most circumstances, `cabal-install` will directly call `Cabal` library functions
+to build packages:
+
+ - We no longer need `cabal-install` to act as a Setup (the `--act-as-setup`
+ flag). We used to need this to set the working directory and to redirect
+ logging output, but that can now be done via `Cabal` library functions.
+ - Packages with `build-type: Hooks` are now also built via `Cabal` library
+ functions instead of the `Setup.hs` interface. `cabal-install` achieves this
+ by building an external hooks executable with which it communicates to
+ run `SetupHooks`.
+
+The main upside of this change is that we waste less time re-running the entire
+`Cabal` `configure` step; instead `cabal-install` directly starts off with
+the information it already knows (compiler, versions of dependencies given by
+the solver, flag assignment, etc). This necessitated refactoring the `Cabal`
+`configure` code in order to skip running the unnecessary initial steps that
+are made redundant by the information from `cabal-install`'s `ElaboratedReadyPackage`.
+
+There should be no outward-facing change in behaviour beside speeding up the
+`configure` step.
diff --git a/changelog.d/pr-10487.md b/changelog.d/pr-10487.md
new file mode 100644
index 00000000000..ea0e3064bb9
--- /dev/null
+++ b/changelog.d/pr-10487.md
@@ -0,0 +1,18 @@
+---
+synopsis: Fix `cabal run` handling of `--` with empty targets
+packages: [cabal-install]
+prs: 10487
+issues: 10487
+---
+
+Previously, when using `--` to separate cabal options from executable
+arguments, without an explicit target, the first argument after `--` was
+incorrectly treated as a target selector.
+
+For example, the following now works as expected while it failed before
+thinking that `+RTS` is a target:
+
+```
+$ cabal run -- +RTS -s
+$ cabal run -w /path/to/ghc -- +RTS -s
+```
diff --git a/changelog.d/pr-11401 b/changelog.d/pr-11401
new file mode 100644
index 00000000000..37573b337bc
--- /dev/null
+++ b/changelog.d/pr-11401
@@ -0,0 +1,12 @@
+synopsis: Fix the OS string encoding for GNU/Hurd
+packages: Cabal
+prs: #11401
+
+description: {
+
+Following [#9434](https://github.com/haskell/cabal/pull/9434/), and as seen
+in the various `gnu_HOST_OS` uses in the GHC source code, it is expected that
+GNU/Hurd is advertised as "gnu", so the OS String encoding for OSHurd was
+corrected to "gnu".
+
+}
diff --git a/changelog.d/pr-11429.md b/changelog.d/pr-11429.md
new file mode 100644
index 00000000000..b7a17109728
--- /dev/null
+++ b/changelog.d/pr-11429.md
@@ -0,0 +1,27 @@
+---
+synopsis: Ensure consistency of `Cabal` version for `SetupHooks`
+packages: [cabal-install]
+prs: 11429
+issues: 11331
+---
+
+When building a package with `build-type: Hooks`, we build an executable which
+is invoked during the build process to perform build steps. This executable
+needs to be linked against the `Cabal` library, therefore we now add a
+dependency on `Cabal` when solving dependencies for the setup stanza.
+
+This fixes a bug which resulted in the solver choosing two inconsistent versions
+of the `Cabal` library, avoiding strange error messages like:
+
+```
+SetupHooks.hs: error: [GHC-83865]
+ • Couldn't match expected type ‘Distribution.Verbosity.Verbosity’
+ with actual type ‘Verbosity’
+ NB: ‘Distribution.Verbosity.Verbosity’
+ is defined in ‘Distribution.Verbosity’ in package ‘Cabal-3.16.0.0’
+ ‘Verbosity’
+ is defined in ‘Distribution.Verbosity’ in package ‘Cabal-3.16.0.0’
+```
+
+where the error is that there are two different unit IDs for `Cabal` being
+passed when compiling the `SetupHooks` module.
diff --git a/changelog.d/pr-11514.md b/changelog.d/pr-11514.md
new file mode 100644
index 00000000000..ff87688ca4b
--- /dev/null
+++ b/changelog.d/pr-11514.md
@@ -0,0 +1,8 @@
+synopsis: Change unsupported ghc version warning to info
+packages: Cabal
+prs: #11514
+issues: #9734
+
+description: {
+The warning "Unknown/unsupported 'ghc' version detected (Cabal 3.12.1.0 supports 'ghc' version < 9.12): /usr/bin/ghc-9.12.3 is version 9.12.3" is now only shown at Info level of verbosity.
+}
diff --git a/changelog.d/pr-11604.md b/changelog.d/pr-11604.md
index ee134388885..9c05ce1d910 100644
--- a/changelog.d/pr-11604.md
+++ b/changelog.d/pr-11604.md
@@ -1,7 +1,7 @@
---
synopsis: Replace removeDirectoryRecursive with removePathForcibly
packages: [Cabal, cabal-install]
-prs: 11599
+prs: 11604
---
We replace `System.Directory.removeDirectoryRecursive` calls with a more robust `System.Directory.removePathForcibly`. Additionally, some functions (most notably the one responsible for `cabal clean`) now run `removeDirectoryRecursive` twice on all platforms if the first time was not successful (previously only on Windows) and include a small delay in between.
diff --git a/changelog.d/pr-11616.md b/changelog.d/pr-11616.md
new file mode 100644
index 00000000000..12112065ab6
--- /dev/null
+++ b/changelog.d/pr-11616.md
@@ -0,0 +1,9 @@
+---
+synopsis: Introduce removeFileForcibly, remove
+packages: [Cabal, cabal-install]
+prs: 11616
+---
+
+Introduce a robust file removing helper `Distribution.Simple.Utils.removeFileForcibly`, similar in spirit to `System.Directory.removePathForcibly`.
+
+Remove `Distribution.Client.Utils.removeExistingFile`, use aforementioned `removeFileForcibly` instead.
diff --git a/changelog.d/pr-11621.md b/changelog.d/pr-11621.md
new file mode 100644
index 00000000000..3abb81c026e
--- /dev/null
+++ b/changelog.d/pr-11621.md
@@ -0,0 +1,8 @@
+---
+synopsis: Fix typos explitic
+packages: [Cabal]
+prs: 11621
+---
+
+Changes `CheckExplanation` constructor `CVExpliticDepsCustomSetup` and
+`CheckExplanationID` constructor `CICVExpliticDepsCustomSetup`.
diff --git a/changelog.d/pr-11626.md b/changelog.d/pr-11626.md
new file mode 100644
index 00000000000..94b084c364f
--- /dev/null
+++ b/changelog.d/pr-11626.md
@@ -0,0 +1,13 @@
+---
+synopsis: Remove duplicated constraints from CondTree
+packages: [Cabal-syntax]
+prs: 11626
+---
+
+`CondTree` is often instantiated with `a` being a component that has `BuildInfo` and `c` as
+`[Dependency]`. The `[Dependency]` is derived from the `BuildInfo` during construction.
+
+The accessors are exposed, this duplication of `[Dependency]` can cause the data to be inconsistent.
+
+Cabal exact print aims to allow modifications to the GPD. Not having a single source of truth can
+also confuse programmers using GPD as an API to exact print.
diff --git a/changelog.d/pr-11658.md b/changelog.d/pr-11658.md
new file mode 100644
index 00000000000..d59aeff3eb2
--- /dev/null
+++ b/changelog.d/pr-11658.md
@@ -0,0 +1,15 @@
+---
+synopsis: Implement recursive globs in file monitoring
+packages: [cabal-install]
+prs: 11658
+issues: [10064]
+significance: significant
+---
+Directory recursive globs (e.g. `foo/**/*.hs`) are now supported by
+`cabal-install`'s file monitoring implementation. A double asterisk (`**`) in a
+glob indicates recursive directory traversal (much like in most Unix-style
+shells).
+
+Just like elsewhere in Cabal (and unlike most shells), `**` is limited to the
+last directory component of a path, so `/foo/bar/**/*.txt` is valid, but
+`/foo/**/bar/*.txt` is not.
diff --git a/changelog.d/pr-11684 b/changelog.d/pr-11684
new file mode 100644
index 00000000000..70583b7c6ca
--- /dev/null
+++ b/changelog.d/pr-11684
@@ -0,0 +1,12 @@
+---
+synopsis: Add unit tests for active-repositories feature
+packages: [cabal-install]
+prs: 11684
+---
+
+Add unit tests for the `active-repositories` cabal configuration field:
+
+- `organizeByRepos`: ordering and strategy assignment with `:rest`, named repos, and error cases
+- `filterSkippedActiveRepos`: filtering of skipped entries in the absence of `:rest`
+- `CombineStrategy` index-combining logic (Skip/Merge/Override)
+- Parse/pretty roundtrip for `ActiveRepos` (QuickCheck)
diff --git a/doc/cabal-commands.rst b/doc/cabal-commands.rst
index 06a1e082373..ca05df1b42b 100644
--- a/doc/cabal-commands.rst
+++ b/doc/cabal-commands.rst
@@ -1212,8 +1212,9 @@ When ``TARGET`` is one of the following:
- Empty target: Same as package target, implicitly using the package from the current
working directory.
-Except in the case of the empty target, the strings after it will be
-passed to the executable as arguments.
+With a non-empty target, the strings after it are passed to the
+executable as arguments. With an empty target you must use ``--`` to
+separate executable arguments from cabal flags.
If one of the arguments starts with ``-`` it will be interpreted as
a cabal flag, so if you need to pass flags to the executable you
@@ -1222,6 +1223,10 @@ have to separate them with ``--``.
::
$ cabal run target -- -a -bcd --argument
+ $ cabal run -- +RTS -s -RTS
+
+The second form (empty target with ``--``) runs the single executable
+in the current package and passes the RTS options to it.
``run`` supports running script files that use a certain format.
Scripts look like:
diff --git a/doc/pyproject.toml b/doc/pyproject.toml
index d2487a12972..d5b4443a512 100644
--- a/doc/pyproject.toml
+++ b/doc/pyproject.toml
@@ -14,8 +14,8 @@ ignore_file = '.skjoldignore'
# certifi>=2023.07.22 by CVE-2023-37920
# idna>=3.7 by CVE-2024-3651
# jinja2>=3.1.4 by CVE-2024-34064
-# pygments>=2.7.4 by CVE-2021-20270 CVE-2021-27291
-# requests>=2.32.0 by CVE-2024-35195
+# pygments>=2.20.0 by CVE-2021-20270 CVE-2021-27291 CVE-2026-4539
+# requests>=2.33.0 by CVE-2024-35195 CVE-2026-25645
# urllib3>=2.0.7 by CVE-2023-45803
[dependency-groups]
dev = [
@@ -23,8 +23,8 @@ dev = [
"idna>=3.7",
"jinja2>=3.1.4",
"packaging>=25.0",
- "pygments>=2.7.4",
- "requests>=2.32.0",
+ "pygments>=2.20.0",
+ "requests>=2.33.0",
"sphinx>=8.2.3",
"sphinx-jsonschema>=1.19.2",
"sphinx-rtd-theme>=3.0.2",
diff --git a/doc/uv.lock b/doc/uv.lock
index 9ed6da96696..3650b51ce44 100644
--- a/doc/uv.lock
+++ b/doc/uv.lock
@@ -10,8 +10,8 @@ dev = [
{ name = "idna", specifier = ">=3.7" },
{ name = "jinja2", specifier = ">=3.1.4" },
{ name = "packaging", specifier = ">=25.0" },
- { name = "pygments", specifier = ">=2.7.4" },
- { name = "requests", specifier = ">=2.32.0" },
+ { name = "pygments", specifier = ">=2.20.0" },
+ { name = "requests", specifier = ">=2.33.0" },
{ name = "sphinx", specifier = ">=8.2.3" },
{ name = "sphinx-jsonschema", specifier = ">=1.19.2" },
{ name = "sphinx-rtd-theme", specifier = ">=3.0.2" },
@@ -234,11 +234,11 @@ wheels = [
[[package]]
name = "pygments"
-version = "2.19.2"
+version = "2.20.0"
source = { registry = "https://pypi.org/simple" }
-sdist = { url = "https://files.pythonhosted.org/packages/b0/77/a5b8c569bf593b0140bde72ea885a803b82086995367bf2037de0159d924/pygments-2.19.2.tar.gz", hash = "sha256:636cb2477cec7f8952536970bc533bc43743542f70392ae026374600add5b887", size = 4968631, upload-time = "2025-06-21T13:39:12.283Z" }
+sdist = { url = "https://files.pythonhosted.org/packages/c3/b2/bc9c9196916376152d655522fdcebac55e66de6603a76a02bca1b6414f6c/pygments-2.20.0.tar.gz", hash = "sha256:6757cd03768053ff99f3039c1a36d6c0aa0b263438fcab17520b30a303a82b5f", size = 4955991, upload-time = "2026-03-29T13:29:33.898Z" }
wheels = [
- { url = "https://files.pythonhosted.org/packages/c7/21/705964c7812476f378728bdf590ca4b771ec72385c533964653c68e86bdc/pygments-2.19.2-py3-none-any.whl", hash = "sha256:86540386c03d588bb81d44bc3928634ff26449851e99741617ecb9037ee5ec0b", size = 1225217, upload-time = "2025-06-21T13:39:07.939Z" },
+ { url = "https://files.pythonhosted.org/packages/f4/7e/a72dd26f3b0f4f2bf1dd8923c85f7ceb43172af56d63c7383eb62b332364/pygments-2.20.0-py3-none-any.whl", hash = "sha256:81a9e26dd42fd28a23a2d169d86d7ac03b46e2f8b59ed4698fb4785f946d0176", size = 1231151, upload-time = "2026-03-29T13:29:30.038Z" },
]
[[package]]
@@ -289,7 +289,7 @@ wheels = [
[[package]]
name = "requests"
-version = "2.32.5"
+version = "2.33.1"
source = { registry = "https://pypi.org/simple" }
dependencies = [
{ name = "certifi" },
@@ -297,9 +297,9 @@ dependencies = [
{ name = "idna" },
{ name = "urllib3" },
]
-sdist = { url = "https://files.pythonhosted.org/packages/c9/74/b3ff8e6c8446842c3f5c837e9c3dfcfe2018ea6ecef224c710c85ef728f4/requests-2.32.5.tar.gz", hash = "sha256:dbba0bac56e100853db0ea71b82b4dfd5fe2bf6d3754a8893c3af500cec7d7cf", size = 134517, upload-time = "2025-08-18T20:46:02.573Z" }
+sdist = { url = "https://files.pythonhosted.org/packages/5f/a4/98b9c7c6428a668bf7e42ebb7c79d576a1c3c1e3ae2d47e674b468388871/requests-2.33.1.tar.gz", hash = "sha256:18817f8c57c6263968bc123d237e3b8b08ac046f5456bd1e307ee8f4250d3517", size = 134120, upload-time = "2026-03-30T16:09:15.531Z" }
wheels = [
- { url = "https://files.pythonhosted.org/packages/1e/db/4254e3eabe8020b458f1a747140d32277ec7a271daf1d235b70dc0b4e6e3/requests-2.32.5-py3-none-any.whl", hash = "sha256:2462f94637a34fd532264295e186976db0f5d453d1cdd31473c85a6a161affb6", size = 64738, upload-time = "2025-08-18T20:46:00.542Z" },
+ { url = "https://files.pythonhosted.org/packages/d7/8e/7540e8a2036f79a125c1d2ebadf69ed7901608859186c856fa0388ef4197/requests-2.33.1-py3-none-any.whl", hash = "sha256:4e6d1ef462f3626a1f0a0a9c42dd93c63bad33f9f1c1937509b8c5c8718ab56a", size = 64947, upload-time = "2026-03-30T16:09:13.83Z" },
]
[[package]]
diff --git a/editors/vim/syntax/cabal.vim b/editors/vim/syntax/cabal.vim
index 3d2600253e5..c7694c65cb3 100644
--- a/editors/vim/syntax/cabal.vim
+++ b/editors/vim/syntax/cabal.vim
@@ -162,8 +162,8 @@ syn keyword cabalExtension contained
\ ConstraintKinds
\ DataKinds
\ DatatypeContexts
- \ DefaultSignatures
\ DeepSubsumption
+ \ DefaultSignatures
\ DeriveAnyClass
\ DeriveDataTypeable
\ DeriveFoldable
@@ -182,6 +182,7 @@ syn keyword cabalExtension contained
\ EmptyDataDeriving
\ ExistentialQuantification
\ ExplicitForAll
+ \ ExplicitLevelImports
\ ExplicitNamespaces
\ ExtendedDefaultRules
\ ExtendedLiterals
@@ -201,6 +202,7 @@ syn keyword cabalExtension contained
\ HexFloatLiterals
\ ImplicitParams
\ ImplicitPrelude
+ \ ImplicitStagePersistence
\ ImportQualifiedPost
\ ImpredicativeTypes
\ IncoherentInstances
@@ -213,16 +215,15 @@ syn keyword cabalExtension contained
\ LiberalTypeSynonyms
\ LinearTypes
\ ListTuplePuns
- \ RequiredTypeArguments
\ MagicHash
\ MonadComprehensions
\ MonadFailDesugaring
\ MonoLocalBinds
\ MonoPatBinds
\ MonomorphismRestriction
- \ MultilineStrings
\ MultiParamTypeClasses
\ MultiWayIf
+ \ MultilineStrings
\ NPlusKPatterns
\ NamedDefaults
\ NamedFieldPuns
@@ -260,6 +261,7 @@ syn keyword cabalExtension contained
\ RecursiveDo
\ RegularPatterns
\ RelaxedPolyRec
+ \ RequiredTypeArguments
\ RestrictedTypeSynonyms
\ RoleAnnotations
\ SafeImports
@@ -307,8 +309,8 @@ syn keyword cabalExtension contained
\ NoConstraintKinds
\ NoDataKinds
\ NoDatatypeContexts
- \ NoDefaultSignatures
\ NoDeepSubsumption
+ \ NoDefaultSignatures
\ NoDeriveAnyClass
\ NoDeriveDataTypeable
\ NoDeriveFoldable
@@ -327,6 +329,7 @@ syn keyword cabalExtension contained
\ NoEmptyDataDeriving
\ NoExistentialQuantification
\ NoExplicitForAll
+ \ NoExplicitLevelImports
\ NoExplicitNamespaces
\ NoExtendedDefaultRules
\ NoExtendedLiterals
@@ -346,6 +349,7 @@ syn keyword cabalExtension contained
\ NoHexFloatLiterals
\ NoImplicitParams
\ NoImplicitPrelude
+ \ NoImplicitStagePersistence
\ NoImportQualifiedPost
\ NoImpredicativeTypes
\ NoIncoherentInstances
@@ -357,16 +361,15 @@ syn keyword cabalExtension contained
\ NoLexicalNegation
\ NoLiberalTypeSynonyms
\ NoLinearTypes
- \ NoRequiredTypeArguments
\ NoMagicHash
\ NoMonadComprehensions
\ NoMonadFailDesugaring
\ NoMonoLocalBinds
\ NoMonoPatBinds
\ NoMonomorphismRestriction
- \ NoMultilineStrings
\ NoMultiParamTypeClasses
\ NoMultiWayIf
+ \ NoMultilineStrings
\ NoNPlusKPatterns
\ NoNamedDefaults
\ NoNamedFieldPuns
@@ -377,12 +380,12 @@ syn keyword cabalExtension contained
\ NoNullaryTypeClasses
\ NoNumDecimals
\ NoNumericUnderscores
+ \ NoOrPatterns
\ NoOverlappingInstances
\ NoOverloadedLabels
\ NoOverloadedLists
\ NoOverloadedRecordDot
\ NoOverloadedStrings
- \ NoOrPatterns
\ NoPackageImports
\ NoParallelArrays
\ NoParallelListComp
@@ -404,6 +407,7 @@ syn keyword cabalExtension contained
\ NoRecursiveDo
\ NoRegularPatterns
\ NoRelaxedPolyRec
+ \ NoRequiredTypeArguments
\ NoRestrictedTypeSynonyms
\ NoRoleAnnotations
\ NoSafeImports
diff --git a/hooks-exe/Setup.hs b/hooks-exe/Setup.hs
new file mode 100644
index 00000000000..021805cb81a
--- /dev/null
+++ b/hooks-exe/Setup.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/hooks-exe/changelog.md b/hooks-exe/changelog.md
new file mode 100644
index 00000000000..cb4ff3c7140
--- /dev/null
+++ b/hooks-exe/changelog.md
@@ -0,0 +1,6 @@
+# Changelog for `hooks-exe`
+
+## 0.1 – April 2026
+
+ * Initial release of `Hooks` integration for `cabal-install`.
+
diff --git a/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs
new file mode 100644
index 00000000000..6ef2313496c
--- /dev/null
+++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe.hs
@@ -0,0 +1,238 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{- HLINT ignore "Use curry" -}
+
+module Distribution.Client.SetupHooks.CallHooksExe
+ ( callHooksExe
+ , externalSetupHooks
+ , externalSetupHooksABI
+ , buildTypeSetupHooks
+ , buildTypePreBuildHooks
+ , runExternalPreBuildRules
+ , hooksProgFilePath
+ ) where
+
+-- base
+import GHC.Stack
+
+-- bytestring
+import Data.ByteString.Lazy as LBS
+ ( hGetContents
+ , hPut
+ , null
+ )
+
+-- process
+import qualified System.Process as P
+import System.Process.CommunicationHandle
+ ( readCreateProcessWithExitCodeCommunicationHandle )
+
+-- filepath
+import System.FilePath
+ ( (), (<.>) )
+
+-- Cabal
+import Distribution.Compat.Prelude
+import qualified Distribution.Compat.Binary as Binary
+import Distribution.Simple
+ ( autoconfSetupHooks )
+import Distribution.Simple.Build
+ ( builtinPreBuildHooks )
+import Distribution.Simple.BuildPaths
+ ( exeExtension )
+import Distribution.Simple.SetupHooks.Internal
+import Distribution.Simple.SetupHooks.Rule
+import Distribution.Simple.Utils
+ ( dieWithException )
+import Distribution.System
+ ( buildPlatform )
+import Distribution.Types.BuildType
+ ( BuildType(..) )
+import Distribution.Utils.Path
+ ( CWD
+ , Dist
+ , Pkg
+ , SymbolicPath
+ , FileOrDir(..)
+ , interpretSymbolicPath
+ )
+import Distribution.Verbosity
+ ( Verbosity, VerbosityHandles, mkVerbosity )
+
+-- hooks-cli
+import Distribution.Client.SetupHooks.CallHooksExe.Errors
+import Distribution.Simple.SetupHooks.HooksMain
+ ( HooksVersion )
+
+--------------------------------------------------------------------------------
+
+type HookIO inputs outputs =
+ ( HasCallStack
+ , Typeable inputs, Typeable outputs
+ , Binary inputs, Binary outputs
+ )
+
+-- | Call an external hooks executable in order to execute a Cabal Setup hook.
+callHooksExe
+ :: forall inputs outputs
+ . HookIO inputs outputs
+ => Verbosity
+ -> FilePath -- ^ path to hooks executable
+ -> String -- ^ name of the hook to run
+ -> inputs -- ^ argument to the hook
+ -> IO outputs
+callHooksExe verb hooksExe hookName input = do
+ (ex, output) <-
+ -- The arguments to the external hooks executable are:
+ --
+ -- 1. Input handle, from which the hooks executable receives its input.
+ -- 2. Output handle, to which the hooks executable writes its output.
+ -- 3. The hook type to run.
+ --
+ -- The hooks executable will read input from the input handle, decode it,
+ -- run the necessary hook, producing a result which it encodes and writes
+ -- to the output handle.
+ readCreateProcessWithExitCodeCommunicationHandle
+ ( \(theyRead, theyWrite) -> P.proc hooksExe [show theyRead, show theyWrite, hookName] )
+ ( \ hWeRead -> hGetContents hWeRead )
+ ( \ hWeWrite -> do
+ let i = Binary.encode input
+ unless (LBS.null i) $
+ hPut hWeWrite i
+ )
+ case ex of
+ ExitFailure exitCode ->
+ dieWithException verb $
+ HookFailed hookName $
+ HookException exitCode
+ ExitSuccess -> do
+ let mbOutput = Binary.decodeOrFail output
+ case mbOutput of
+ Left (_, offset, err) -> do
+ dieWithException verb $
+ HookFailed hookName $
+ CouldNotDecodeOutput output offset err
+ Right (_, _, res) -> return res
+
+-- | Construct a 'SetupHooks' that runs the hooks of the external hooks executable
+-- at the given path through the CLI.
+--
+-- This should only be used at the final step of compiling a package, when we
+-- have all the hooks in hand. The SetupHooks that are returned by this function
+-- cannot be combined with any other SetupHooks; they must directly be used to
+-- build the package.
+externalSetupHooks :: Verbosity -> FilePath -> SetupHooks
+externalSetupHooks verb hooksExe =
+ SetupHooks
+ { configureHooks =
+ ConfigureHooks
+ { preConfPackageHook = Just $ hook "preConfPackage"
+ , postConfPackageHook = Just $ hook "postConfPackage"
+ , preConfComponentHook = Just $ hook "preConfComponent"
+ }
+ , buildHooks =
+ BuildHooks
+ { -- NB: external pre-build rules are special, due to the StaticPtr machinery.
+ -- To invoke them, we must separately call 'runExternalPreBuildRules'.
+ preBuildComponentRules = Nothing
+ , postBuildComponentHook = Just $ hook "postBuildComponent"
+ }
+ , installHooks =
+ InstallHooks
+ { installComponentHook = Just $ hook "installComponent"
+ }
+ }
+ where
+ hook :: HookIO inputs outputs => String -> inputs -> IO outputs
+ hook = callHooksExe verb hooksExe
+
+-- | The ABI of an external hooks executable.
+--
+-- This information is used to handshake before further communication,
+-- in order to avoid a cascade of errors with mismatched 'Binary' instances.
+externalSetupHooksABI :: Verbosity -> FilePath -> IO HooksVersion
+externalSetupHooksABI verb hooksExe =
+ callHooksExe verb hooksExe "version" ()
+
+-- | The 'SetupHooks' associated to a particular 'BuildType'.
+--
+-- **Warning:** for @build-type: Hooks@, this does not include the pre-build
+-- hooks. Those can be retrieved with 'buildTypePreBuildHooks'.
+buildTypeSetupHooks
+ :: Verbosity
+ -> Maybe (SymbolicPath CWD (Dir Pkg))
+ -> SymbolicPath Pkg (Dir Dist)
+ -> BuildType
+ -> SetupHooks
+buildTypeSetupHooks verb mbWorkDir distPref = \case
+ Hooks -> externalSetupHooks verb $ hooksProgFilePath mbWorkDir distPref
+ Configure -> autoconfSetupHooks
+ _ -> noSetupHooks
+ -- Note: if any built-in functionality is implemented using SetupHooks,
+ -- we would also need to include those.
+
+-- | The pre-build hooks obtained by communication with an external hooks executable.
+buildTypePreBuildHooks
+ :: VerbosityHandles
+ -> Maybe (SymbolicPath CWD (Dir Pkg))
+ -> SymbolicPath Pkg (Dir Dist)
+ -> BuildType
+ -> ( PreBuildComponentInputs -> IO [MonitorFilePath] )
+buildTypePreBuildHooks verbHandles mbWorkDir distPref bt pbci = do
+ builtinMons <- builtinPreBuildHooks bt pbci
+ externalMons <- case bt of
+ Hooks ->
+ runExternalPreBuildRules verbHandles
+ (hooksProgFilePath mbWorkDir distPref)
+ pbci
+ _ -> return []
+ return (builtinMons ++ externalMons)
+
+-- | Run pre-build rules coming from an external hooks executable at the
+-- given filepath.
+--
+-- Note that 'executeRulesUserOrSystem' handles recompilation checking, only
+-- re-running rules that are stale.
+runExternalPreBuildRules
+ :: VerbosityHandles
+ -> FilePath -- ^ path to external hooks executable
+ -> PreBuildComponentInputs
+ -> IO [MonitorFilePath]
+runExternalPreBuildRules verbHandles hooksExe
+ pbci@PreBuildComponentInputs
+ { buildingWhat = what
+ , localBuildInfo = lbi
+ , targetInfo = tgt } = do
+ let verbFlags = buildingWhatVerbosity what
+ verbosity = mkVerbosity verbHandles verbFlags
+ hook :: HookIO inputs outputs => String -> inputs -> IO outputs
+ hook = callHooksExe verbosity hooksExe
+ -- Here we make sure to use 'RuleBinary' (@'Scope' == 'System'@)
+ -- to avoid looking up static pointer keys from the hooks executable
+ -- from the outside (e.g. from within cabal-install).
+ (rulesMap :: Map RuleId RuleBinary, monitors) <- hook "preBuildRules" pbci
+ executeRulesUserOrSystem
+ SSystem
+ ( \ rId cmd -> case cmd of
+ StaticRuleCommand {} -> return Nothing
+ DynamicRuleCommands {} -> hook "runPreBuildRuleDeps" (rId, cmd)
+ )
+ ( \ rId cmd -> hook "runPreBuildRule" (rId, cmd) )
+ verbosity lbi tgt rulesMap
+ return monitors
+
+-- | The path to the external hooks executable.
+hooksProgFilePath
+ :: Maybe (SymbolicPath CWD (Dir Pkg))
+ -> SymbolicPath Pkg (Dir Dist)
+ -> FilePath
+hooksProgFilePath mbWorkDir distPref =
+ interpretSymbolicPath mbWorkDir distPref
+ "setup"
+ "hooks"
+ <.> exeExtension buildPlatform
diff --git a/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs
new file mode 100644
index 00000000000..521cf585562
--- /dev/null
+++ b/hooks-exe/cli/Distribution/Client/SetupHooks/CallHooksExe/Errors.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Distribution.Client.SetupHooks.CallHooksExe.Errors
+ ( HookInput(..)
+ , SetupHooksCallExeException (..)
+ , HookFailedReason(..)
+ , setupHooksCallExeExceptionCode
+ , setupHooksCallExeExceptionMessage
+ ) where
+
+-- Cabal
+import Distribution.Compat.Binary
+ ( Binary )
+import Distribution.Simple.Utils
+
+-- base
+import GHC.Exception
+import Data.Int
+ ( Int64 )
+import Data.Typeable
+ ( Typeable )
+
+-- bytestring
+import Data.ByteString.Lazy
+ ( ByteString )
+
+--------------------------------------------------------------------------------
+
+data HookInput where
+ HookInput :: (Binary input, Typeable input, Show input)
+ => input -> HookInput
+instance Show HookInput where
+ show (HookInput input) = show input
+
+data SetupHooksCallExeException
+ = HookFailed
+ String
+ -- ^ hook name
+ HookFailedReason
+ -- ^ why did the hook fail?
+ deriving Show
+
+data HookFailedReason
+ -- | The hooks executable terminated with non-zero exit code.
+ = HookException
+ Int -- ^ exit code
+ -- | We failed to decode the output of the hooks executable.
+ | CouldNotDecodeOutput
+ ByteString
+ -- ^ hook output that we failed to decode
+ Int64
+ -- ^ byte offset at which the decoding error took place
+ String
+ -- ^ info about the decoding error
+ deriving Show
+
+setupHooksCallExeExceptionCode :: SetupHooksCallExeException -> Int
+setupHooksCallExeExceptionCode = \case
+ HookFailed _ reason -> setupHooksCallExeFailedExceptionCode reason
+
+setupHooksCallExeFailedExceptionCode :: HookFailedReason -> Int
+setupHooksCallExeFailedExceptionCode = \case
+ HookException {} -> 7717
+ CouldNotDecodeOutput {} -> 5412
+
+setupHooksCallExeExceptionMessage :: SetupHooksCallExeException -> String
+setupHooksCallExeExceptionMessage = \case
+ HookFailed hookName reason ->
+ setupHooksCallExeFailedMessage hookName reason
+
+setupHooksCallExeFailedMessage :: String -> HookFailedReason -> String
+setupHooksCallExeFailedMessage hookName = \case
+ HookException {} ->
+ "An exception occurred when running the " ++ hookName ++ " hook."
+ CouldNotDecodeOutput _bytes offset err ->
+ "Failed to decode the output of the " ++ hookName ++ " hook.\n\
+ \Decoding failed at position " ++ show offset ++ " with error: " ++ err ++ ".\n\
+ \This could be due to a mismatch between the Cabal version of cabal-install and of the hooks executable."
+
+instance Exception (VerboseException SetupHooksCallExeException) where
+ displayException (VerboseException stack timestamp verb err) =
+ withOutputMarker
+ verb
+ ( concat
+ [ "Error: [Cabal-"
+ , show (setupHooksCallExeExceptionCode err)
+ , "]\n"
+ ]
+ )
+ ++ exceptionWithMetadata stack timestamp verb (setupHooksCallExeExceptionMessage err)
diff --git a/hooks-exe/hooks-exe.cabal b/hooks-exe/hooks-exe.cabal
new file mode 100644
index 00000000000..a733c807e38
--- /dev/null
+++ b/hooks-exe/hooks-exe.cabal
@@ -0,0 +1,56 @@
+cabal-version: 3.0
+name: hooks-exe
+version: 0.1
+copyright: 2024, Cabal Development Team
+license: BSD-3-Clause
+author: Cabal Development Team
+maintainer: cabal-devel@haskell.org
+homepage: http://www.haskell.org/cabal/
+bug-reports: https://github.com/haskell/cabal/issues
+synopsis: cabal-install integration for Hooks build-type
+description:
+ Layer for integrating Hooks build-type with cabal-install
+category: Distribution
+build-type: Simple
+
+extra-source-files:
+ readme.md changelog.md
+
+common warnings
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Wnoncanonical-monad-instances -Wincomplete-uni-patterns
+ -Wincomplete-record-updates
+ -fno-warn-unticked-promoted-constructors
+ if impl(ghc < 8.8)
+ ghc-options: -Wnoncanonical-monadfail-instances
+ if impl(ghc >=9.0)
+ -- Warning: even though introduced with GHC 8.10, -Wunused-packages
+ -- gives false positives with GHC 8.10.
+ ghc-options: -Wunused-packages
+
+-- Library imported by cabal-install to interface with an external
+-- hooks executable.
+library
+ import: warnings
+ hs-source-dirs:
+ cli
+ build-depends:
+ base
+ >= 4.10 && < 5,
+ bytestring
+ >= 0.10.6.0 && < 0.13,
+ filepath
+ >= 1.4.0.0 && < 1.6 ,
+ process
+ >= 1.6.20.0 && < 1.7 ,
+ Cabal-syntax, Cabal
+
+ exposed-modules:
+ Distribution.Client.SetupHooks.CallHooksExe
+ other-modules:
+ Distribution.Client.SetupHooks.CallHooksExe.Errors
+
+ default-language:
+ Haskell2010
diff --git a/hooks-exe/readme.md b/hooks-exe/readme.md
new file mode 100644
index 00000000000..05614591214
--- /dev/null
+++ b/hooks-exe/readme.md
@@ -0,0 +1,4 @@
+# `hooks-exe`
+
+This library integrates `Cabal`'s `Hooks` build-type into `cabal-install`.
+It is only meant to be used by `cabal-install`, not imported by users.
diff --git a/project-cabal/pkgs/install.config b/project-cabal/pkgs/install.config
index 9010d1f332b..328b95385d4 100644
--- a/project-cabal/pkgs/install.config
+++ b/project-cabal/pkgs/install.config
@@ -1,3 +1,4 @@
packages:
cabal-install
, cabal-install-solver
+ , hooks-exe
diff --git a/templates/Paths_pkg.template.hs b/templates/Paths_pkg.template.hs
index 9577070e169..5f04cd3aa05 100644
--- a/templates/Paths_pkg.template.hs
+++ b/templates/Paths_pkg.template.hs
@@ -1,9 +1,5 @@
-{% if supportsCpp %}
{-# LANGUAGE CPP #-}
-{% endif %}
-{% if supportsNoRebindableSyntax %}
{-# LANGUAGE NoRebindableSyntax #-}
-{% endif %}
{% if not absolute %}
{-# LANGUAGE ForeignFunctionInterface #-}
{% endif %}
@@ -45,23 +41,8 @@ import Prelude
import System.Environment (getExecutablePath)
{% endif %}
-{% if supportsCpp %}
-#if defined(VERSION_base)
-
-#if MIN_VERSION_base(4,0,0)
-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#else
-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a
-#endif
-
-#else
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#endif
catchIO = Exception.catch
-{% else %}
-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-catchIO = Exception.catch
-{% endif %}
-- |The package version.
version :: Version